RomanNum3ral
/
Cybersecurity-Projects
mirror of https://github.com/CarterPerez-dev/Cybersecurity-Projects.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

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

Chore/haskell reverse proxy finish
This commit is contained in:
Carter Perez 2026-04-29 02:55:51 -04:00 committed by GitHub
parent 3f9bb07096 15f795f10c
commit 09542d3a83
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
31 changed files with 1362 additions and 1122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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

4
PROJECTS/advanced/encrypted-p2p-chat/compose.yml
View File

@ -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}

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

@ -1,17 +1,18 @@
# ©AngelaMos | 2025
# Development Vite Dockerfile
# HMR dev server, volume mounts for code
# ©AngelaMos | 2026
# vite.docker
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"]

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

@ -1,18 +1,19 @@
# ©AngelaMos | 2025
# Production Vite Dockerfile
# Multi-stage: build with node, serve with nginx
# ©AngelaMos | 2026
# vite.docker
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

18
PROJECTS/advanced/encrypted-p2p-chat/dev.compose.yml
View File

@ -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

3
PROJECTS/advanced/haskell-reverse-proxy/aenebris.cabal
View File

@ -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

57
PROJECTS/advanced/haskell-reverse-proxy/app/Main.hs
View File

@ -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
case validateConfig config of
Left err -> do
hPutStrLn stderr $ "ERROR: Invalid configuration"
hPutStrLn stderr err
exitFailure
Right config -> case validateConfig config of
Left err -> do
hPutStrLn stderr "ERROR: Invalid configuration"
hPutStrLn stderr err
exitFailure
Right () -> do
putStrLn "Configuration loaded and validated successfully"
-- Create HTTP client manager with connection pooling
manager <- newManager defaultManagerSettings
-- Initialize proxy state (load balancers + health checkers)
proxyState <- initProxyState config manager
-- Start the proxy
startProxy proxyState
Right () -> do
putStrLn "Configuration loaded and validated successfully"
let upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig
* microsPerSecond
managerSettings = defaultManagerSettings
{ managerResponseTimeout = responseTimeoutMicro upstreamMicros
}
manager <- newManager managerSettings
proxyState <- initProxyState config manager
startProxy proxyState

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

@ -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
, rbHost :: Text
, rbWeight :: Int
-- Runtime state (STM)
, rbActiveConnections :: TVar Int
, rbCurrentWeight :: TVar Int
, rbHealthState :: TVar BackendState
, rbConsecutiveFailures :: TVar Int
, rbConsecutiveSuccesses :: TVar Int
, rbLastHealthCheck :: TVar (Maybe UTCTime)
, rbTotalRequests :: TVar Int -- For metrics
, rbTotalFailures :: TVar Int -- For metrics
{ rbServerId :: !Int
, rbHost :: !Text
, rbWeight :: !Int
, rbActiveConnections :: !(TVar Int)
, rbCurrentWeight :: !(TVar Int)
, rbHealthState :: !(TVar BackendState)
, rbConsecutiveFailures :: !(TVar Int)
, rbConsecutiveSuccesses :: !(TVar Int)
, rbLastHealthCheck :: !(TVar (Maybe UTCTime))
, rbTotalRequests :: !(TVar Int)
, rbTotalFailures :: !(TVar Int)
}
instance Show RuntimeBackend where
show rb = "RuntimeBackend {id=" ++ show (rbServerId rb) ++
", host=" ++ show (rbHost rb) ++ "}"
show rb = "RuntimeBackend {id="
++ 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
atomically $ RuntimeBackend serverId serverHost serverWeight
<$> newTVar 0 -- activeConnections
<*> newTVar 0 -- currentWeight (for smooth WRR)
<*> newTVar Healthy -- healthState
<*> newTVar 0 -- consecutiveFailures
<*> newTVar 0 -- consecutiveSuccesses
<*> newTVar Nothing -- lastHealthCheck
<*> newTVar 0 -- totalRequests
<*> newTVar 0 -- totalFailures
createRuntimeBackend serverId Server{..} = atomically $
RuntimeBackend serverId serverHost serverWeight
<$> newTVar initialActiveConnections
<*> newTVar initialCurrentWeight
<*> newTVar Healthy
<*> newTVar initialFailureCount
<*> newTVar initialSuccessCount
<*> newTVar Nothing
<*> newTVar initialMetricCount
<*> 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' (rbTotalRequests rb) (+1))
modifyTVar' (rbActiveConnections rb) (+ 1)
modifyTVar' (rbTotalRequests rb) (+ 1))
(atomically $ modifyTVar' (rbActiveConnections rb) (subtract 1))
action
-- | Get current connection count
getConnectionCount :: RuntimeBackend -> STM Int
getConnectionCount rb = readTVar (rbActiveConnections rb)
-- | Get current weight (for smooth weighted RR)
getCurrentWeight :: RuntimeBackend -> STM Int
getCurrentWeight rb = readTVar (rbCurrentWeight rb)
-- | State transition: mark as unhealthy
transitionToUnhealthy :: RuntimeBackend -> STM ()
transitionToUnhealthy rb = do
writeTVar (rbHealthState rb) Unhealthy
writeTVar (rbConsecutiveFailures rb) 0
writeTVar (rbConsecutiveSuccesses rb) 0
writeTVar (rbConsecutiveFailures rb) initialFailureCount
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 (rbConsecutiveSuccesses rb) 0
writeTVar (rbConsecutiveFailures rb) initialFailureCount
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 -> do
-- Failed during recovery, back to unhealthy
Recovering ->
transitionToUnhealthy rb
Unhealthy ->
-- Already unhealthy, just record it
modifyTVar' (rbTotalFailures rb) (+1)
pure ()
-- | Record a health check success
recordSuccess :: RuntimeBackend -> Int -> STM ()
recordSuccess rb recoveryAttempts = do
state <- readTVar (rbHealthState rb)
successes <- readTVar (rbConsecutiveSuccesses rb)
case state of
Healthy ->
-- Reset failure counter
writeTVar (rbConsecutiveFailures rb) 0
writeTVar (rbConsecutiveFailures rb) initialFailureCount
Unhealthy ->
-- First success, transition to recovering
transitionToRecovering rb
Recovering -> do
let newSuccesses = successes + 1
writeTVar (rbConsecutiveSuccesses rb) newSuccesses

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

@ -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
, configListen :: [ListenConfig]
, configUpstreams :: [Upstream]
, configRoutes :: [Route]
, configRateLimit :: Maybe Text
, configDDoS :: Maybe DDoSConfig
, configHoneypot :: Maybe HoneypotConfigYaml
, configGeo :: Maybe GeoConfigYaml
{ configVersion :: !Int
, configListen :: ![ListenConfig]
, configUpstreams :: ![Upstream]
, configRoutes :: ![Route]
, configRateLimit :: !(Maybe Text)
, configDDoS :: !(Maybe DDoSConfig)
, configHoneypot :: !(Maybe HoneypotConfigYaml)
, configGeo :: !(Maybe GeoConfigYaml)
} deriving (Show, Eq, Generic)
instance FromJSON Config where
parseJSON = withObject "Config" $ \v -> Config
<$> v .: "version"
<*> v .: "listen"
<*> v .: "upstreams"
<*> v .: "routes"
<$> v .: "version"
<*> v .: "listen"
<*> v .: "upstreams"
<*> v .: "routes"
<*> v .:? "rate_limit"
<*> v .:? "ddos"
<*> v .:? "honeypot"
<*> v .:? "geo"
data DDoSConfig = DDoSConfig
{ ddosEarlyDataReject :: Bool
, ddosPerIPConnections :: Maybe Int
, ddosMemoryShedBytes :: Maybe Integer
, ddosMemoryShedHighWater :: Maybe Double
, ddosMaxConcurrentStreams :: Maybe Int
, ddosMaxHeaderBytes :: Maybe Int
, ddosSlowlorisSeconds :: Maybe Int
, ddosJailCooldownSeconds :: Maybe Int
, ddosReusePort :: Bool
{ ddosEarlyDataReject :: !Bool
, ddosPerIPConnections :: !(Maybe Int)
, ddosMemoryShedBytes :: !(Maybe Integer)
, ddosMemoryShedHighWater :: !(Maybe Double)
, ddosMaxConcurrentStreams :: !(Maybe Int)
, ddosMaxHeaderBytes :: !(Maybe Int)
, ddosSlowlorisSeconds :: !(Maybe Int)
, ddosJailCooldownSeconds :: !(Maybe Int)
, 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
, ddosPerIPConnections = Nothing
, ddosMemoryShedBytes = Nothing
, ddosMemoryShedHighWater = Nothing
{ ddosEarlyDataReject = True
, ddosPerIPConnections = Nothing
, ddosMemoryShedBytes = Nothing
, ddosMemoryShedHighWater = Nothing
, ddosMaxConcurrentStreams = Nothing
, ddosMaxHeaderBytes = Nothing
, ddosSlowlorisSeconds = Nothing
, ddosJailCooldownSeconds = Nothing
, ddosReusePort = False
, ddosMaxHeaderBytes = Nothing
, ddosSlowlorisSeconds = Nothing
, ddosJailCooldownSeconds = Nothing
, ddosReusePort = False
}
-- | Listen port configuration
data ListenConfig = ListenConfig
{ listenPort :: Int
, listenTLS :: Maybe TLSConfig
, listenRedirectHTTPS :: Maybe Bool -- Redirect HTTP to HTTPS?
{ listenPort :: !Int
, listenTLS :: !(Maybe TLSConfig)
, 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)
, tlsKey :: Maybe FilePath -- Single key (if not using SNI)
, tlsSNI :: Maybe [SNIDomain] -- SNI domains (multiple certs)
, tlsDefaultCert :: Maybe FilePath -- Default cert for SNI
, tlsDefaultKey :: Maybe FilePath -- Default key for SNI
{ tlsCert :: !(Maybe FilePath)
, tlsKey :: !(Maybe FilePath)
, tlsSNI :: !(Maybe [SNIDomain])
, tlsDefaultCert :: !(Maybe FilePath)
, 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
, sniCert :: FilePath
, sniKey :: FilePath
{ sniDomain :: !Text
, sniCert :: !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
, upstreamServers :: [Server]
, upstreamHealthCheck :: Maybe HealthCheck
{ upstreamName :: !Text
, upstreamServers :: ![Server]
, upstreamHealthCheck :: !(Maybe HealthCheck)
} deriving (Show, Eq, Generic)
instance FromJSON Upstream where
parseJSON = withObject "Upstream" $ \v -> Upstream
<$> v .: "name"
<*> v .: "servers"
<$> v .: "name"
<*> v .: "servers"
<*> v .:? "health_check"
-- | Backend server with weight for load balancing
data Server = Server
{ serverHost :: Text
, serverWeight :: Int
{ serverHost :: !Text
, 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
, healthCheckInterval :: Text -- e.g., "10s"
{ healthCheckPath :: !Text
, 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
, routePaths :: [PathRoute]
{ routeHost :: !Text
, 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
, pathRouteUpstream :: Text
, pathRouteRateLimit :: Maybe Text -- e.g., "100/minute"
{ pathRoutePath :: !Text
, pathRouteUpstream :: !Text
, pathRouteRateLimit :: !(Maybe Text)
} deriving (Show, Eq, Generic)
instance FromJSON PathRoute where
parseJSON = withObject "PathRoute" $ \v -> PathRoute
<$> v .: "path"
<*> v .: "upstream"
<$> v .: "path"
<*> 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
Left err -> Left (show err)
pure $ case result of
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 /= 1) $
Left "Unsupported config version (expected: 1)"
when (configVersion config /= supportedConfigVersion) $
Left ("Unsupported config version (expected: "
++ 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) $
Left $ "Invalid port number: " ++ show port
-- Validate TLS configuration if present
when (port < minPort || port > maxPort) $
Left ("Invalid port number: " ++ show port)
case listenTLS listen of
Nothing -> return ()
Just tlsConf -> validateTLS tlsConf
Nothing -> pure ()
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) $
Left $ "Upstream '" ++ T.unpack (upstreamName upstream) ++ "' has no servers"
when (null (upstreamServers upstream)) $
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
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) $
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) $
Left $ "Route for host '" ++ T.unpack (routeHost route) ++ "' has no paths"
when (null (routePaths route)) $
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 ()
where
-- Helper to remove duplicates from Text list
nubText :: [Text] -> [Text]
nubText [] = []
nubText (x:xs) = x : nubText (filter (/= x) xs)
pure ()
-- Validate TLS configuration
validateTLS :: TLSConfig -> Either String ()
validateTLS tlsConf = do
let hasSingleCert = case (tlsCert tlsConf, tlsKey tlsConf) of
(Just _, Just _) -> True
(Nothing, Nothing) -> False
_ -> False -- One is set but not the other
validateTLS :: TLSConfig -> Either String ()
validateTLS tlsConf = do
let hasSingleCert = case (tlsCert tlsConf, tlsKey tlsConf) of
(Just _, Just _) -> True
_ -> False
hasSNI = case (tlsSNI tlsConf, tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of
(Just sniDomains, Just _, Just _) -> not (null sniDomains)
_ -> False
hasSNI = case (tlsSNI tlsConf, tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of
(Just sniDomains, Just _, Just _) -> not (null sniDomains)
_ -> False
when (not hasSingleCert && not hasSNI) $
Left "TLS configuration must specify either (cert + key) or (sni + default_cert + default_key)"
-- Must have either single cert or SNI configuration
when (not hasSingleCert && not hasSNI) $
Left "TLS configuration must specify either (cert + key) or (sni + default_cert + default_key)"
when (hasSingleCert && hasSNI) $
Left "TLS configuration cannot have both single cert and SNI configuration"
-- Can't have both single cert and SNI
when (hasSingleCert && hasSNI) $
Left "TLS configuration cannot have both single cert and SNI configuration"
when hasSingleCert $
case (tlsCert tlsConf, tlsKey tlsConf) of
(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 (hasSingleCert) $ do
case (tlsCert tlsConf, tlsKey tlsConf) of
(Just _, Nothing) -> Left "TLS cert specified but key missing"
(Nothing, Just _) -> Left "TLS key specified but cert missing"
_ -> return ()
when hasSNI $
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"
_ -> pure ()
-- If SNI, ensure default cert/key are present
when (hasSNI) $ do
case (tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of
(Just _, Nothing) -> Left "SNI default_cert specified but default_key missing"
(Nothing, Just _) -> Left "SNI default_key specified but default_cert missing"
(Nothing, Nothing) -> Left "SNI configuration requires default_cert and default_key"
_ -> return ()
return ()
pure ()

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

@ -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
, tcWebSocketTunnel :: Int
, tcStreamingResponse :: Int
, tcProxyPingInterval :: Int
, tcPongTimeout :: Int
, tcConnectTimeout :: Int
{ tcHttpIdle :: !Int
, tcWebSocketTunnel :: !Int
, tcStreamingResponse :: !Int
, tcProxyPingInterval :: !Int
, tcPongTimeout :: !Int
, tcConnectTimeout :: !Int
, tcUpstreamReadSeconds :: !Int
}
defaultTimeoutConfig :: TimeoutConfig
defaultTimeoutConfig = TimeoutConfig
{ tcHttpIdle = 60
, tcWebSocketTunnel = 3600
, tcStreamingResponse = 3600
, tcProxyPingInterval = 30
, tcPongTimeout = 10
, tcConnectTimeout = 5
{ tcHttpIdle = 60
, tcWebSocketTunnel = 3600
, tcStreamingResponse = 3600
, tcProxyPingInterval = 30
, tcPongTimeout = 10
, 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

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

@ -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
( HostAddress6
, SockAddr(..)
, hostAddress6ToTuple
, hostAddressToTuple
)
import Numeric (showHex)
import Text.Printf (printf)
import Network.Socket (SockAddr)
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) =
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
ipBytesFromSockAddr = sockAddrToIPBytes

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

@ -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

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

@ -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)

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

@ -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
, hcTimeout :: Int -- Request timeout (seconds)
, hcEndpoint :: Text -- Health endpoint path (e.g., "/health")
, hcMaxFailures :: Int -- Failures before marking unhealthy
, hcRecoveryAttempts :: Int -- Successes before marking healthy
{ hcInterval :: !Int
, hcTimeout :: !Int
, hcEndpoint :: !Text
, hcMaxFailures :: !Int
, hcRecoveryAttempts :: !Int
}
-- | Default health check configuration
defaultHealthCheckConfig :: HealthCheckConfig
defaultHealthCheckConfig = HealthCheckConfig
{ hcInterval = 10
, hcTimeout = 2
, hcEndpoint = "/health"
, hcMaxFailures = 3
, hcRecoveryAttempts = 2
{ hcInterval = defaultHealthCheckIntervalSeconds
, hcTimeout = defaultHealthCheckTimeoutSeconds
, hcEndpoint = defaultHealthCheckEndpoint
, hcMaxFailures = defaultHealthCheckMaxFailures
, hcRecoveryAttempts = defaultHealthCheckRecoveryAttempts
}
-- | Start health checker (returns Async handle for stopping)
startHealthChecker :: Manager -> HealthCheckConfig -> [RuntimeBackend] -> IO (Async ())
startHealthChecker
:: 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)
-- Try to make request with timeout
result <- timeout (hcTimeout config * 1000000) $ do
result <- timeout (hcTimeout config * microsPerSecond) $ do
req <- parseRequest url
response <- httpLbs req manager
return $ statusCode (responseStatus response) == 200
-- Update last check time
pure (statusCode (responseStatus response) == httpOkStatusCode)
now <- getCurrentTime
atomically $ writeTVar (rbLastHealthCheck backend) (Just now)
return $ case result of
pure $ 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)

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

@ -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

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

@ -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
, lbStrategy :: LoadBalancerStrategy
, lbRRCounter :: IORef Int -- For round robin
{ lbBackends :: !(Vector RuntimeBackend)
, lbStrategy :: !LoadBalancerStrategy
, lbRRCounter :: !(IORef Int)
}
-- | Create a load balancer for given backends
createLoadBalancer :: LoadBalancerStrategy -> [RuntimeBackend] -> IO LoadBalancer
createLoadBalancer
:: LoadBalancerStrategy -> [RuntimeBackend] -> IO LoadBalancer
createLoadBalancer strategy backends = do
counter <- newIORef 0
return LoadBalancer
{ lbBackends = V.fromList backends
, lbStrategy = strategy
counter <- newIORef initialRoundRobinIndex
pure LoadBalancer
{ lbBackends = V.fromList backends
, lbStrategy = strategy
, lbRRCounter = counter
}
-- | Select a backend using the configured strategy
selectBackend :: LoadBalancer -> IO (Maybe RuntimeBackend)
selectBackend lb =
case lbStrategy lb of
RoundRobin -> selectRoundRobin lb
LeastConnections -> selectLeastConnections lb
WeightedRoundRobin -> selectWeightedRR lb
selectBackend lb = case lbStrategy lb of
RoundRobin -> selectRoundRobin lb
LeastConnections -> selectLeastConnections lb
WeightedRoundRobin -> selectWeightedRR lb
-- Round-Robin Implementation (IORef-based, fastest)
selectRoundRobin :: LoadBalancer -> IO (Maybe RuntimeBackend)
selectRoundRobin LoadBalancer{..} = do
let backends = lbBackends
len = V.length backends
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 :: Vector RuntimeBackend -> Int -> Int -> IO (Maybe RuntimeBackend)
findHealthyBackend backends startIdx totalBackends =
go startIdx totalBackends
findHealthyBackend
:: Vector RuntimeBackend -> Int -> Int -> IO (Maybe RuntimeBackend)
findHealthyBackend backends startIdx totalBackends = go startIdx totalBackends
where
len = V.length backends
go currentIdx remaining
| remaining <= 0 = return Nothing -- Tried all, none healthy
| 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
backends' -> do
-- Get connection counts for all healthy backends
counts <- mapM getConnectionCount backends'
[] -> pure Nothing
chosen -> do
counts <- mapM getConnectionCount chosen
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
backends' -> do
-- Step 1: Increase each backend's current weight by its base weight
forM_ backends' $ \rb -> do
currentW <- readTVar (rbCurrentWeight rb)
let newWeight = currentW + rbWeight rb
writeTVar (rbCurrentWeight rb) newWeight
-- Step 2: Select backend with maximum current weight
weights <- mapM getCurrentWeight backends'
let maxWeight = maximum weights
selectedIdx = find (\i -> weights !! i == maxWeight) [0..length weights - 1]
selected = backends' !! (fromMaybe 0 selectedIdx)
-- Step 3: Reduce selected backend's current weight by total weight
let totalWeight = sum (map rbWeight backends')
currentW <- readTVar (rbCurrentWeight selected)
writeTVar (rbCurrentWeight selected) (currentW - totalWeight)
return (Just selected)
-- Helper: STM filter
filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
filterM _ [] = return []
filterM p (x:xs) = do
b <- p x
rest <- filterM p xs
return $ if b then x : rest else rest
-- Helper: fromMaybe
fromMaybe :: a -> Maybe a -> a
fromMaybe def Nothing = def
fromMaybe _ (Just x) = x
-- Helper: forM_
forM_ :: Monad m => [a] -> (a -> m b) -> m ()
forM_ xs f = sequence_ (map f xs)
[] -> pure Nothing
chosen -> do
forM_ chosen $ \rb ->
modifyTVar' (rbCurrentWeight rb) (+ rbWeight rb)
tagged <- mapM
(\rb -> (\w -> (w, rb)) <$> readTVar (rbCurrentWeight rb))
chosen
let (_, picked) = maximumBy (comparing fst) tagged
totalWeight = sum (map rbWeight chosen)
modifyTVar' (rbCurrentWeight picked) (subtract totalWeight)
pure (Just picked)

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

@ -494,17 +494,17 @@ extractFeatures FeatureContext{..} req =
let !headers = requestHeaders req
!path = rawPathInfo req
!method = requestMethod req
!mAcceptLang = lookupCI acceptLanguageHeader headers
!mUserAgent = lookupCI userAgentHeader headers
!mAcceptEnc = lookupCI acceptEncodingHeader headers
!mReferer = lookupCI refererHeader headers
!mCookie = lookupCI cookieHeader headers
!mSecChUa = lookupCI secChUaHeader headers
!mSecChPlat = lookupCI secChUaPlatformHeader headers
!mSecFetchSite = lookupCI secFetchSiteHeader headers
!mSecFetchMode = lookupCI secFetchModeHeader headers
!mSecFetchDest = lookupCI secFetchDestHeader headers
!mAccept = lookupCI acceptHeader headers
!mAcceptLang = lookup acceptLanguageHeader headers
!mUserAgent = lookup userAgentHeader headers
!mAcceptEnc = lookup acceptEncodingHeader headers
!mReferer = lookup refererHeader headers
!mCookie = lookup cookieHeader headers
!mSecChUa = lookup secChUaHeader headers
!mSecChPlat = lookup secChUaPlatformHeader headers
!mSecFetchSite = lookup secFetchSiteHeader headers
!mSecFetchMode = lookup secFetchModeHeader headers
!mSecFetchDest = lookup secFetchDestHeader 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

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

@ -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
ITreeLeaf !size ->
fromIntegral currentDepth + normalizationConstant size
ITreeSplit !featIdx !thr !left !right ->
let !fval = fv VU.! featIdx
in if fval <= thr
then pathLength left fv (currentDepth + 1)
else pathLength right fv (currentDepth + 1)
pathLength !tree !fv !currentDepth
| currentDepth >= maxIForestDepth =
fromIntegral currentDepth + normalizationConstant depthBoundLeafSize
| otherwise = case tree of
ITreeLeaf !size ->
fromIntegral currentDepth + normalizationConstant size
ITreeSplit !featIdx !thr !left !right ->
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

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

@ -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
[] -> Right []
((n, ln):rest)
| T.strip ln == endOfTreesMarker -> Right []
| T.isPrefixOf baseTreeKeyPrefix (T.strip ln) -> do
let (block, after) = break (lineIsBlank . snd) rest
tree <- parseTreeBlock block
more <- runTrees after
Right (tree : more)
| otherwise -> Left
(ParseError n treeKey
("Expected 'Tree=N' or 'end of trees', got: " <> ln))
runTrees = goTrees 0
where
goTrees :: Int -> [(Int, Text)] -> Either ParseError [Tree]
goTrees treeCount lns
| treeCount > maxNumTrees = Left
(ParseError postParseLineSentinel treeKey
("Tree count exceeds maxNumTrees "
<> T.pack (show maxNumTrees)))
| otherwise = case dropWhile (lineIsBlank . snd) lns of
[] -> Right []
((n, ln):rest)
| 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)

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

@ -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 =

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

@ -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
nBound = VU.length (treeCatBoundaries t)
if nBound < 2
let rawThreshold = treeThreshold t VU.! i
catIdx = floor rawThreshold :: Int
nBound = VU.length (treeCatBoundaries t)
if fromIntegral catIdx /= rawThreshold
then Left ("Categorical node " <> show i
<> " requires non-empty cat_boundaries")
else if catIdx < 0 || catIdx >= nBound - 1
<> " has non-integer threshold " <> show rawThreshold)
else if nBound < 2
then Left ("Categorical node " <> show i
<> " has out-of-range bitmap slice index " <> show catIdx)
else Right ()
<> " requires non-empty cat_boundaries")
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

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

@ -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.Wai (Middleware, responseLBS, requestHeaderHost, rawPathInfo, rawQueryString, isSecure)
import Network.HTTP.Types (hLocation, status301)
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 "localhost" $ requestHeaderHost req
-- Build HTTPS URL with optional port
let hostHeader = fromMaybe defaultHostFallback (requestHeaderHost req)
host = case httpsPort of
Nothing -> hostHeader -- Standard 443, don't include port
Just 443 -> hostHeader -- Standard 443, don't include port
Nothing -> hostHeader
Just port | port == standardHttpsPort -> hostHeader
Just port -> hostHeader <> ":" <> BS.pack (show port)
-- Get path and query string (already encoded in rawPathInfo)
path = rawPathInfo req
query = rawQueryString req
-- Build full redirect URL
redirectUrl = "https://" <> host <> path <> query
-- Send 301 permanent redirect
path = rawPathInfo req
query = rawQueryString req
redirectUrl = httpsScheme <> host <> path <> query
respond $ responseLBS
status301
[(hLocation, redirectUrl)]
"Redirecting to HTTPS"
(BS.fromStrict redirectBody)

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

@ -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
| Production -- Balanced security for production
| Strict -- Maximum security, strict CSP, HSTS preload
= Testing
| Production
| Strict
deriving (Show, Eq)
-- | Security configuration
data SecurityConfig = SecurityConfig
{ scHSTS :: Maybe ByteString -- Strict-Transport-Security header
, scCSP :: Maybe ByteString -- Content-Security-Policy header
, scFrameOptions :: Maybe ByteString -- X-Frame-Options header
, scContentTypeOptions :: Bool -- X-Content-Type-Options: nosniff
, scReferrerPolicy :: Maybe ByteString -- Referrer-Policy header
, scPermissionsPolicy :: Maybe ByteString -- Permissions-Policy header
, scXSSProtection :: Maybe ByteString -- X-XSS-Protection (legacy, but some crawlers check)
, scExpectCT :: Maybe ByteString -- Expect-CT (transitional)
, scServerHeader :: Maybe ByteString -- Server header (hide or customize)
, scRemovePoweredBy :: Bool -- Remove X-Powered-By headers
{ scHSTS :: !(Maybe ByteString)
, scCSP :: !(Maybe ByteString)
, scFrameOptions :: !(Maybe ByteString)
, scContentTypeOptions :: !Bool
, scReferrerPolicy :: !(Maybe ByteString)
, scPermissionsPolicy :: !(Maybe ByteString)
, scXSSProtection :: !(Maybe ByteString)
, scExpectCT :: !(Maybe ByteString)
, scServerHeader :: !(Maybe ByteString)
, 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
, scCSP = Just "default-src 'self' 'unsafe-inline' 'unsafe-eval'; script-src 'self' 'unsafe-inline' 'unsafe-eval'; style-src 'self' 'unsafe-inline'"
, scFrameOptions = Just "SAMEORIGIN"
, scContentTypeOptions = True
, scReferrerPolicy = Just "strict-origin-when-cross-origin"
, scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=()"
, scXSSProtection = Just "1; mode=block"
, scExpectCT = Nothing
, scServerHeader = Just "Aenebris/0.1.0"
, scRemovePoweredBy = True
{ 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'"
, scFrameOptions = Just "SAMEORIGIN"
, scContentTypeOptions = True
, scReferrerPolicy = Just "strict-origin-when-cross-origin"
, scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=()"
, scXSSProtection = Just "1; mode=block"
, scExpectCT = Nothing
, scServerHeader = Just "Aenebris/0.1.0"
, scRemovePoweredBy = True
}
-- | Production security configuration
-- Balanced security, 1-month HSTS
defaultSecurityConfig :: SecurityConfig
defaultSecurityConfig = SecurityConfig
{ scHSTS = Just "max-age=2592000; includeSubDomains" -- 30 days
, scCSP = Just "default-src 'self'; script-src 'self'; style-src 'self' 'unsafe-inline'; img-src 'self' data: https:; font-src 'self' data:; connect-src 'self'; frame-ancestors 'none'"
, scFrameOptions = Just "DENY"
, scContentTypeOptions = True
, scReferrerPolicy = Just "strict-origin-when-cross-origin"
, scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=()"
, scXSSProtection = Just "1; mode=block"
, scExpectCT = Just "max-age=86400, enforce"
, scServerHeader = Just "Aenebris" -- Don't reveal version in production
, scRemovePoweredBy = True
{ 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'"
, scFrameOptions = Just "DENY"
, scContentTypeOptions = True
, scReferrerPolicy = Just "strict-origin-when-cross-origin"
, scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=()"
, scXSSProtection = Just "1; mode=block"
, scExpectCT = Just "max-age=86400, enforce"
, scServerHeader = Just "Aenebris"
, scRemovePoweredBy = True
}
-- | Strict security configuration for maximum protection
-- 2-year HSTS with preload, very restrictive CSP
strictSecurityConfig :: SecurityConfig
strictSecurityConfig = SecurityConfig
{ scHSTS = Just "max-age=63072000; includeSubDomains; preload" -- 2 years + preload
, scCSP = Just "default-src 'none'; script-src 'self'; style-src 'self'; img-src 'self' data:; font-src 'self'; connect-src 'self'; frame-ancestors 'none'; base-uri 'self'; form-action 'self'; upgrade-insecure-requests"
, scFrameOptions = Just "DENY"
, scContentTypeOptions = True
, scReferrerPolicy = Just "no-referrer" -- Strictest, no referrer leakage
, scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=(), bluetooth=(), display-capture=(), document-domain=()"
, scXSSProtection = Just "1; mode=block"
, scExpectCT = Just "max-age=86400, enforce"
, scServerHeader = Nothing -- Hide completely
, scRemovePoweredBy = True
{ 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"
, scFrameOptions = Just "DENY"
, scContentTypeOptions = True
, scReferrerPolicy = Just "no-referrer"
, scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=(), bluetooth=(), display-capture=(), document-domain=()"
, scXSSProtection = Just "1; mode=block"
, scExpectCT = Just "max-age=86400, enforce"
, scServerHeader = Nothing
, scRemovePoweredBy = True
}
-- | Middleware that adds security headers to all responses
addSecurityHeaders :: SecurityConfig -> Middleware
addSecurityHeaders config app req respond =
app req $ \res ->
respond $ mapResponseHeaders (addHeaders config) res
-- | Add security headers to response headers
addHeaders :: SecurityConfig -> ResponseHeaders -> ResponseHeaders
addHeaders config headers =
let
-- Remove headers we want to control
cleaned = if scRemovePoweredBy config
then filter (not . isPoweredBy) headers
else headers
-- Build new security headers
newHeaders = catMaybes
[ fmap (\v -> ("Strict-Transport-Security", v)) (scHSTS config)
, fmap (\v -> ("Content-Security-Policy", v)) (scCSP config)
, fmap (\v -> ("X-Frame-Options", v)) (scFrameOptions config)
, if scContentTypeOptions config
then Just ("X-Content-Type-Options", "nosniff")
else Nothing
, fmap (\v -> ("Referrer-Policy", v)) (scReferrerPolicy config)
, fmap (\v -> ("Permissions-Policy", v)) (scPermissionsPolicy config)
, fmap (\v -> ("X-XSS-Protection", v)) (scXSSProtection config)
, fmap (\v -> ("Expect-CT", v)) (scExpectCT config)
]
-- Handle Server header specially
serverHeader = case scServerHeader config of
Just v -> [("Server", v)]
Nothing -> [] -- Remove Server header completely
-- Remove existing Server header if we're replacing it
withoutServer = filter (not . isServerHeader) cleaned
let cleaned = if scRemovePoweredBy config
then filter (not . isPoweredBy) headers
else headers
newHeaders = catMaybes
[ fmap (\v -> ("Strict-Transport-Security", v)) (scHSTS config)
, fmap (\v -> ("Content-Security-Policy", v)) (scCSP config)
, fmap (\v -> ("X-Frame-Options", v)) (scFrameOptions config)
, if scContentTypeOptions config
then Just ("X-Content-Type-Options", "nosniff")
else Nothing
, fmap (\v -> ("Referrer-Policy", v)) (scReferrerPolicy config)
, fmap (\v -> ("Permissions-Policy", v)) (scPermissionsPolicy config)
, fmap (\v -> ("X-XSS-Protection", v)) (scXSSProtection config)
, fmap (\v -> ("Expect-CT", v)) (scExpectCT config)
]
serverHeader = case scServerHeader config of
Just v -> [("Server", v)]
Nothing -> []
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) []

43
PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Net/IP.hs Normal file
View File

@ -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))

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

@ -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 qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as LBS
import System.Timeout (timeout)
memoryShedPollIntervalMicros :: Int
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
, psLoadBalancers :: Map Text LoadBalancer -- upstream name -> load balancer
, psHealthCheckers :: [Async ()]
, psManager :: Manager
, psRateLimiter :: Maybe RateLimiter
, psMemoryShed :: Maybe MemoryShed
, psIPJail :: Maybe IPJail
, psConnLimiter :: Maybe ConnLimiter
, psWafRuleSet :: TVar RuleSet
, psGeo :: Maybe Geo
{ psConfig :: !Config
, psLoadBalancers :: !(Map Text LoadBalancer)
, psHealthCheckers :: ![Async ()]
, psManager :: !Manager
, psRateLimiter :: !(Maybe RateLimiter)
, psMemoryShed :: !(Maybe MemoryShed)
, psIPJail :: !(Maybe IPJail)
, psConnLimiter :: !(Maybe ConnLimiter)
, psWafRuleSet :: !(TVar RuleSet)
, 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)
, mscPollIntervalMicros = 1000000
, mscHighWaterFraction = fromMaybe defaultHighWaterFraction
(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
, psLoadBalancers = lbMap
{ psConfig = config
, psLoadBalancers = lbMap
, psHealthCheckers = checkers
, psManager = manager
, psRateLimiter = rateLimiter
, psMemoryShed = memShed
, psIPJail = ipJail
, psConnLimiter = connLimiter
, psWafRuleSet = wafVar
, psGeo = geoHandle
, psManager = manager
, psRateLimiter = rateLimiter
, psMemoryShed = memShed
, psIPJail = ipJail
, psConnLimiter = connLimiter
, psWafRuleSet = wafVar
, 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
(w:ws) -> if all (== w) ws
then RoundRobin
else WeightedRoundRobin
[] -> RoundRobin
(w:ws)
| all (== w) ws -> RoundRobin
| 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 $ "Loaded " ++ show (length $ configUpstreams psConfig) ++ " upstream(s)"
putStrLn $ "Loaded " ++ show (length $ configRoutes psConfig) ++ " route(s)"
putStrLn $ "Health checking enabled for all upstreams"
putStrLn "Starting Aenebris reverse proxy"
putStrLn $ "Loaded " ++ show (length (configUpstreams psConfig)) ++ " upstream(s)"
putStrLn $ "Loaded " ++ show (length (configRoutes psConfig)) ++ " route(s)"
putStrLn "Health checking enabled for all upstreams"
case configListen psConfig of
[] -> error "No listen ports configured"
[] -> 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))
++ " trap patterns, action=" ++ show (hpAction hp) ++ ")"
Just hp -> putStrLn $
"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)
, "asn_db=" ++ maybe "off" (const "on") (gcAsnDb gc)
, "blocked=" ++ show (length (gcBlockedCountries gc))
, "flagged_asns=" ++ show (length (gcFlaggedAsns gc))
]
parts =
[ "country_db=" ++ maybe "off" (const "on") (gcCountryDb gc)
, "asn_db=" ++ maybe "off" (const "on") (gcAsnDb 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
let port = listenPort listenConfig
shouldRedirect = fromMaybe False (listenRedirectHTTPS listenConfig)
ddosCfg = fromMaybe defaultDDoSConfig (configDDoS config)
launchServer config loadBalancers manager mRateLimiter mMemShed mIPJail mConnLim wafVar mGeo listenConfig =
async $ do
let port = listenPort listenConfig
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
then earlyDataGuard securedApp
else securedApp
jailedApp = case mIPJail of
Just j -> ipJailMiddleware j geoApp
Nothing -> geoApp
mHoneypotCfg = buildHoneypotConfig (configHoneypot config)
shedApp = case mMemShed of
Just ms -> memoryShedMiddleware ms jailedApp
Nothing -> jailedApp
honeypotApp = case mHoneypotCfg of
Just hp -> honeypotMiddleware hp mIPJail earlyDataApp
Nothing -> earlyDataApp
limitedApp = case mRateLimiter of
Just rl -> rateLimitMiddleware rl shedApp
Nothing -> shedApp
geoApp = case mGeo of
Just g -> geoMiddleware g mIPJail honeypotApp
Nothing -> honeypotApp
warpSettings = applyDDoSSettings ddosCfg mConnLim
(defaultSettings & setPort port)
jailedApp = case mIPJail of
Just j -> ipJailMiddleware j geoApp
Nothing -> geoApp
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 pure ()
runSettings warpSettings app
shedApp = case mMemShed of
Just ms -> memoryShedMiddleware ms jailedApp
Nothing -> jailedApp
limitedApp = case mRateLimiter of
Just rl -> rateLimitMiddleware rl shedApp
Nothing -> shedApp
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
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
Just n -> setMaxTotalHeaderLength n s1Inner
Nothing -> s1Inner
s1Inner = case ddosSlowlorisSeconds ddos of
Just n -> setTimeout n s0
let 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 $ " ├─ Certificate: " ++ certFile
putStrLn $ " ├─ TLS 1.2 + TLS 1.3 enabled"
putStrLn $ " ├─ HTTP/2 enabled (ALPN)"
putStrLn $ " └─ Strong cipher suites enforced"
putStrLn $ "* HTTPS server listening on :" ++ show port
putStrLn $ " Certificate: " ++ certFile
putStrLn " TLS 1.2 + TLS 1.3 enabled"
putStrLn " HTTP/2 enabled (ALPN)"
putStrLn " Strong cipher suites enforced"
runTLS tlsSettings warpSettings app
_ -> 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 $ " ├─ SNI domains: " ++ show (length sniDomains) ++ " configured"
mapM_ (\d -> putStrLn $ " │ • " ++ T.unpack (sniDomain d) ++ " -> " ++ sniCert d) sniDomains
putStrLn $ " ├─ Default certificate: " ++ defaultCert
putStrLn $ " ├─ TLS 1.2 + TLS 1.3 enabled"
putStrLn $ " ├─ HTTP/2 enabled (ALPN)"
putStrLn $ " └─ Strong cipher suites enforced"
putStrLn $ "* HTTPS server with SNI listening on :" ++ show port
putStrLn $ " SNI domains: " ++ show (length sniDomains) ++ " configured"
mapM_
(\d -> putStrLn $
" " ++ T.unpack (sniDomain d) ++ " -> " ++ sniCert d)
sniDomains
putStrLn $ " Default certificate: " ++ defaultCert
putStrLn " TLS 1.2 + TLS 1.3 enabled"
putStrLn " HTTP/2 enabled (ALPN)"
putStrLn " Strong cipher suites enforced"
runTLS tlsSettings warpSettings app
_ -> 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
connType = detectConnectionType headers
headers = requestHeaders req
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")]
"Not Found: No route configured for this host/path"
[(hContentType, contentTypePlain)]
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")]
"Internal Server Error: Upstream configuration error"
[(hContentType, contentTypePlain)]
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")]
"Service Unavailable: No healthy backends available"
[(hContentType, contentTypePlain)]
bodyNoHealthyBackends
Just backend -> do
case connType of
WebSocket -> do
hPutStrLn stderr $ "[WS] WebSocket upgrade detected"
handleWebSocketUpgrade req respond backend
Just backend -> case connType of
WebSocket -> do
hPutStrLn stderr "[WS] WebSocket upgrade detected"
handleWebSocketUpgrade req respond backend
_ ->
forwardRegular manager backend req respond
RegularHttp -> do
result <- try $ trackConnection backend $
forwardRequest manager req (rbHost backend) respond
forwardRegular
:: Manager
-> 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
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
_ -> 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
:: Request
-> (Response -> IO ResponseReceived)
-> RuntimeBackend
-> IO ResponseReceived
handleWebSocketUpgrade req respond backend = do
let backendHost = rbHost backend
backupResponse = responseLBS
status502
[("Content-Type", "text/plain")]
"WebSocket upgrade failed"
[(hContentType, contentTypePlain)]
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 :: Config -> Maybe BS.ByteString -> BS.ByteString -> Maybe (Text, PathRoute)
selectRoute config hostHeader requestPath =
case hostHeader of
Nothing -> Nothing -- No Host header, can't route
Just host -> do
-- Find route matching this host
let hostText = TE.decodeUtf8 host
matchingRoutes = filter (\r -> routeHost r == hostText) (configRoutes config)
selectRoute
:: Config
-> Maybe BS.ByteString
-> BS.ByteString
-> Maybe (Text, PathRoute)
selectRoute config hostHeader requestPath = case hostHeader of
Nothing -> Nothing
Just host -> do
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 :: Config -> Maybe BS.ByteString -> BS.ByteString -> Maybe Text
selectUpstream
:: 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 :: Manager -> Request -> Text -> (Response -> IO ResponseReceived) -> IO ResponseReceived
forwardRequest
:: Manager
-> Request
-> Text
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
forwardRequest manager clientReq backendHost respond = do
let backendUrl = "http://" ++ T.unpack backendHost ++
BS8.unpack (rawPathInfo clientReq) ++
BS8.unpack (rawQueryString clientReq)
let backendUrl = httpScheme ++ T.unpack backendHost
++ BS8.unpack (rawPathInfo 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
let status = HTTP.responseStatus backendResponse
headers = HTTP.responseHeaders backendResponse
bodyReader = HTTP.responseBody backendResponse
upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig
* microsPerSecond
if shouldStreamResponse headers
then do
hPutStrLn stderr "[STREAM] Streaming response detected"
respond $ responseStream status (filterResponseHeaders headers) $ \write flush -> do
let loop = do
chunk <- brRead bodyReader
unless (BS.null chunk) $ do
write (byteString chunk)
flush
loop
loop
else do
body <- readFullBody bodyReader
respond $ responseLBS status (filterResponseHeaders headers) body
mResult <- timeout upstreamMicros $
withResponse backendReq manager $ \backendResponse -> do
let status = HTTP.responseStatus backendResponse
headers = HTTP.responseHeaders backendResponse
bodyReader = HTTP.responseBody backendResponse
if shouldStreamResponse headers
then do
hPutStrLn stderr "[STREAM] Streaming response detected"
respond $ responseStream status (filterResponseHeaders headers) $
\write flush -> do
let loop = do
chunk <- brRead bodyReader
unless (BS.null chunk) $ do
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 =
isSSE || isChunkedWithoutLength
shouldStreamResponse headers = 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 = filter (\(name, _) -> name `notElem` hopByHopHeaders)
where
hopByHopHeaders =
[ "Transfer-Encoding"
, "Connection"
, "Keep-Alive"
]
filterResponseHeaders
:: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]
filterResponseHeaders =
filter (\(name, _) -> name `notElem` hopByHopResponseHeaders)
-- | Filter headers for regular HTTP (remove hop-by-hop headers)
filterHeaders :: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]
filterHeaders headers = filter (\(name, _) -> name `notElem` hopByHopHeaders) headers
where
hopByHopHeaders =
[ "Connection"
, "Keep-Alive"
, "Proxy-Authenticate"
, "Proxy-Authorization"
, "TE"
, "Trailers"
, "Transfer-Encoding"
, "Upgrade"
]
-- | Log incoming request
logRequest :: Request -> IO ()
logRequest req = do
let method' = BS8.unpack (requestMethod req)
path = BS8.unpack (rawPathInfo req)
query = BS8.unpack (rawQueryString req)
host = fromMaybe "unknown" $ lookup "Host" (requestHeaders req)
putStrLn $ "[→] " ++ method' ++ " " ++ path ++ query ++ " (Host: " ++ BS8.unpack host ++ ")"
-- Helper: zipWithM
zipWithM :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM f xs ys = sequence (zipWith f xs ys)
filterRequestHeaders
:: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)]
filterRequestHeaders =
filter (\(name, _) -> name `notElem` hopByHopRequestHeaders)

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

@ -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
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
clientIPKey = sockAddrToIPBytes . remoteHost
pathClassKey :: Request -> ByteString
pathClassKey req =

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

@ -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 :: FilePath -> FilePath -> IO (Either CertificateError TLSSettings)
createTLSSettings
:: 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
-- Create TLS settings with strong security
let tlsConfig = (tlsSettings certFile keyFile)
{ tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]
, tlsCiphers = strongCipherSuites
, onInsecure = DenyInsecure "This server requires HTTPS"
}
configureTLS :: FilePath -> FilePath -> TLSSettings
configureTLS certFile keyFile = (tlsSettings certFile keyFile)
{ tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]
, tlsCiphers = strongCipherSuites
, onInsecure = DenyInsecure httpsRequiredMessage
}
return $ Right tlsConfig
-- | Create TLS settings with SNI support for multiple domains
createSNISettings :: [(Text, FilePath, FilePath)] -> FilePath -> FilePath -> IO (Either CertificateError TLSSettings)
createSNISettings
:: [(Text, FilePath, FilePath)]
-> FilePath
-> FilePath
-> IO (Either CertificateError TLSSettings)
createSNISettings domains defaultCert defaultKey = do
-- Validate default certificate
defaultExists <- doesFileExist defaultCert
defaultKeyExists <- doesFileExist defaultKey
if not defaultExists
then return $ Left (CertFileNotFound defaultCert)
else if not defaultKeyExists
then return $ Left (KeyFileNotFound defaultKey)
defaultCertOk <- doesFileExist defaultCert
defaultKeyOk <- doesFileExist defaultKey
if not defaultCertOk
then pure (Left (CertFileNotFound defaultCert))
else if not defaultKeyOk
then pure (Left (KeyFileNotFound defaultKey))
else do
-- Validate all domain certificates exist
validationResults <- mapM validateDomainCert domains
case sequence validationResults of
Left err -> return $ Left err
Right _ -> do
-- Create SNI-enabled TLS settings using the default cert first
let baseTLS = tlsSettings defaultCert defaultKey
tlsConfig = baseTLS
{ tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]
, tlsCiphers = strongCipherSuites
, onInsecure = DenyInsecure "This server requires HTTPS"
, tlsServerHooks = def
{ TLS.onServerNameIndication = \mHostname -> case mHostname of
Nothing -> loadCredentials defaultCert defaultKey
Just hostname -> sniCallback domains defaultCert defaultKey hostname
}
}
validations <- mapM validateDomainCert domains
case sequence validations of
Left err -> pure (Left err)
Right _ -> pure (Right (configureSNI domains defaultCert defaultKey))
return $ Right tlsConfig
where
validateDomainCert :: (Text, FilePath, FilePath) -> IO (Either CertificateError ())
validateDomainCert (domain, certFile, keyFile) = do
certExists <- doesFileExist certFile
keyExists <- doesFileExist keyFile
configureSNI
:: [(Text, FilePath, FilePath)]
-> FilePath
-> FilePath
-> TLSSettings
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
then return $ Left (CertFileNotFound certFile)
else if not keyExists
then return $ Left (KeyFileNotFound keyFile)
else return $ Right ()
validateDomainCert
:: (Text, FilePath, FilePath) -> IO (Either CertificateError ())
validateDomainCert (_domain, certFile, keyFile) = do
certExists <- doesFileExist certFile
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 :: [(Text, FilePath, FilePath)] -> FilePath -> FilePath -> String -> IO TLS.Credentials
sniCallback domains defaultCert defaultKey hostname = do
let hostnameText = T.pack hostname
-- Look up domain in map
sniCallback
:: [(Text, FilePath, FilePath)]
-> FilePath
-> FilePath
-> 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
Nothing -> do
-- No match, use default certificate
loadCredentials defaultCert defaultKey
Just (certFile, keyFile) -> do
-- Found matching domain, load its certificate
loadCredentials certFile keyFile
-- | Load TLS credentials from certificate and key files
loadCredentials :: FilePath -> FilePath -> IO TLS.Credentials
loadCredentials certFile keyFile = do
credentialsOrDefault :: FilePath -> FilePath -> IO TLS.Credentials
credentialsOrDefault certFile keyFile = do
result <- TLS.credentialLoadX509 certFile keyFile
case result of
Left err ->
error $ "Failed to load certificate: " ++ err
Left err -> do
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 :: FilePath -> IO (Either CertificateError [SignedCertificate])
validateCertificate
:: 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.cipher_TLS13_AES128GCM_SHA256
, Cipher.cipher_TLS13_AES256GCM_SHA384
, Cipher.cipher_TLS13_CHACHA20POLY1305_SHA256
] ++
-- TLS 1.2 cipher suites (fallback, only ECDHE + AEAD)
[ Cipher.cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256
[ Cipher.cipher13_AES_128_GCM_SHA256
, Cipher.cipher13_AES_256_GCM_SHA384
, Cipher.cipher13_CHACHA20_POLY1305_SHA256
, 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

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

@ -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
result <- try $ do
let (host, port) = parseHostPort backendHost
bracket
(connectToBackend host port)
Socket.close
$ \backendSocket -> do
sendUpgradeRequest backendSocket clientReq
upgradeResponse <- receiveUpgradeResponse backendSocket
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
let (host, port) = parseHostPort backendHost
outcome <- try $ do
eSock <- connectToBackend host port
case eSock of
Left err -> do
hPutStrLn stderr $ "[WS] Connection failed: " ++ show err
clientSend badGatewayResponseLine
Right sock ->
runUpgrade clientReq clientSend clientRecv sock
`finally` Socket.close sock
case outcome 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)
[host] -> (T.unpack host, 80)
_ -> (T.unpack hostPort, 80)
_ -> (T.unpack host, defaultBackendPort)
[host] -> (T.unpack host, defaultBackendPort)
_ -> (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
[] -> error $ "Cannot resolve: " ++ host ++ ":" ++ show port
(addr:_) -> do
sock <- Socket.socket
(Socket.addrFamily addr)
Socket.Stream
Socket.defaultProtocol
Socket.connect sock (Socket.addrAddress addr)
return sock
attemptConnect
:: String -> Int -> Socket.AddrInfo -> IO (Either ConnectError Socket)
attemptConnect host port addr =
bracketOnError
(Socket.socket
(Socket.addrFamily addr)
Socket.Stream
Socket.defaultProtocol)
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
let method = requestMethod req
path = rawPathInfo req <> rawQueryString req
headers = requestHeaders req
requestLine = method <> " " <> path <> " HTTP/1.1\r\n"
sendUpgradeRequest sock req =
let method = requestMethod req
path = rawPathInfo req <> rawQueryString req
headers = requestHeaders req
requestLine = method <> requestPathSeparator <> path <> httpVersionAndCrlf
headerLines = BS.concat
[ original name <> ": " <> value <> "\r\n"
[ original name <> httpFieldSeparator <> value <> httpHeaderLineEnd
| (name, value) <- headers
]
fullRequest = requestLine <> headerLines <> "\r\n"
SocketBS.sendAll sock fullRequest
fullRequest = requestLine <> headerLines <> httpHeaderLineEnd
in SocketBS.sendAll sock fullRequest
receiveUpgradeResponse :: Socket -> IO ByteString
receiveUpgradeResponse sock = do
chunk <- SocketBS.recv sock 4096
if "\r\n\r\n" `BS.isInfixOf` chunk
then return chunk
else do
rest <- receiveUpgradeResponse sock
return $ chunk <> rest
receiveUpgradeResponse sock = go BS.empty
where
go !acc
| upgradeTerminator `BS.isInfixOf` acc = pure acc
| BS.length acc >= maxUpgradeHeaderBytes = pure acc
| otherwise = do
chunk <- SocketBS.recv sock upgradeRecvChunkBytes
if BS.null chunk
then pure acc
else go (acc <> chunk)
parseUpgradeStatus :: ByteString -> Maybe Int
parseUpgradeStatus response =
case BS8.words (head $ BS8.lines response) of
(_:codeBS:_) ->
case reads (BS8.unpack codeBS) of
[(code, "")] -> Just code
_ -> Nothing
parseUpgradeStatus response = case BS8.lines response of
[] -> Nothing
(firstLine : _) -> case BS8.words firstLine of
(_ : codeBS : _) -> case reads (BS8.unpack codeBS) of
[(code, "")] -> Just code
_ -> Nothing
_ -> Nothing

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

@ -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"

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

@ -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 =
case execute r input of
runRegex cr input =
case execute (unCompiledRegex cr) input of
Right (Just _) -> True
_ -> False

120
PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs
View File

@ -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)
a <- getName
b <- getName
c <- getName
isJust a `shouldBe` True
isJust b `shouldBe` True
isJust c `shouldBe` True
let totalRounds = 9 :: Int
selections <- mapM
(\_ -> fmap (fmap rbServerId) (selectBackend lb))
[1 .. totalRounds]
let counts =
[ length (filter (== Just sid) selections)
| 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
isJust selected `shouldBe` True
let totalRounds = 50 :: Int
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
selected <- selectBackend lb
isJust selected `shouldBe` True
case bks of
[a, _b] -> do
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
rbWeight bk `shouldBe` 10
atomically (recordFailure bk 3)
atomically (isHealthy bk) `shouldReturn` True
atomically (recordFailure bk 3)
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
pure ()
atomically (recordFailure bk 5)
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