Phase 1.1: Organize PROJECTS by difficulty level

- Create beginner/, intermediate/, advanced/ folders in PROJECTS/
- Move all existing projects to appropriate difficulty folders
- Update all README.md links to reflect new structure
- Update contributor links
- Fix pyrightconfig.json trailing comma

Projects organized:
Beginner (6): simple-port-scanner, keylogger, caesar-cipher, dns-lookup, metadata-scrubber-tool, simple-vulnerability-scanner
Intermediate (2): api-security-scanner, docker-security-audit
Advanced (4): api-rate-limiter, encrypted-p2p-chat, bug-bounty-platform, Aenebris
This commit is contained in:
CarterPerez-dev 2026-01-29 02:41:15 -05:00
parent d6978c4bd3
commit a7cae3aa0f
787 changed files with 731 additions and 742 deletions

View File

@ -5,7 +5,7 @@
Technical White Paper & Development Roadmap Technical White Paper & Development Roadmap
Version: 0.1.0 Version: 0.1.0
Date: 2025-11-12 - Project Name: Ᾰenebris Date: 2025-11-12 - Project Name: Ᾰenebris
--- ---
Abstract Abstract

View File

@ -68,14 +68,14 @@ Dhall represents a paradigm shift—a non-Turing-complete functional language sp
```dhall ```dhall
-- types.dhall -- types.dhall
let DatabaseConfig = let DatabaseConfig =
{ Type = { Type =
{ host : Text { host : Text
, port : Natural , port : Natural
, maxConnections : Natural , maxConnections : Natural
, replica : Optional DatabaseConfig.Type , replica : Optional DatabaseConfig.Type
} }
, default = , default =
{ host = "localhost" { host = "localhost"
, port = 5432 , port = 5432
, maxConnections = 20 , maxConnections = 20
@ -87,7 +87,7 @@ let DatabaseConfig =
let DB = ./types.dhall let DB = ./types.dhall
let staging = ./staging.dhall let staging = ./staging.dhall
in DB::{ in DB::{
, host = "prod-db.internal" , host = "prod-db.internal"
, port = 5432 , port = 5432
, maxConnections = 100 , maxConnections = 100
@ -133,11 +133,11 @@ data ServiceConfig = ServiceConfig
-- Type-safe DSL in Haskell -- Type-safe DSL in Haskell
myService :: ServiceConfig myService :: ServiceConfig
myService = ServiceConfig myService = ServiceConfig
{ routes = { routes =
[ route "/api" GET apiHandler [ route "/api" GET apiHandler
, route "/health" GET healthCheck , route "/health" GET healthCheck
] ]
, middleware = , middleware =
[ cors allowAll [ cors allowAll
, logging Verbose , logging Verbose
, auth jwtValidator , auth jwtValidator
@ -205,7 +205,7 @@ let identity : ∀(a : Type) → a → a =
λ(a : Type) → λ(x : a) → x λ(a : Type) → λ(x : a) → x
-- Type-safe record construction -- Type-safe record construction
let Config : Type = let Config : Type =
{ apiKey : Text { apiKey : Text
, endpoints : List { url : Text, port : Natural } , endpoints : List { url : Text, port : Natural }
, retries : Optional Natural , retries : Optional Natural
@ -270,7 +270,7 @@ watchConfigFile = withManager $ \mgr -> do
"." "."
(\event -> "config.yaml" `isSuffixOf` eventPath event) (\event -> "config.yaml" `isSuffixOf` eventPath event)
handleConfigChange handleConfigChange
forever $ threadDelay 1000000 forever $ threadDelay 1000000
handleConfigChange :: Event -> IO () handleConfigChange :: Event -> IO ()
@ -370,7 +370,7 @@ updateConfigs :: TVar AppConfig -> TVar CacheConfig -> IO ()
updateConfigs appVar cacheVar = atomically $ do updateConfigs appVar cacheVar = atomically $ do
app <- readTVar appVar app <- readTVar appVar
cache <- readTVar cacheVar cache <- readTVar cacheVar
-- Both updates happen atomically or retry -- Both updates happen atomically or retry
writeTVar appVar (app { maxConnections = 100 }) writeTVar appVar (app { maxConnections = 100 })
writeTVar cacheVar (cache { ttl = 3600 }) writeTVar cacheVar (cache { ttl = 3600 })
@ -418,16 +418,16 @@ initConfigManager path = do
Right config -> do Right config -> do
currentRef <- newIORef config currentRef <- newIORef config
lastValidRef <- newIORef config lastValidRef <- newIORef config
mgr <- startManager mgr <- startManager
let manager = ConfigManager currentRef lastValidRef path mgr let manager = ConfigManager currentRef lastValidRef path mgr
-- Start watching -- Start watching
_ <- watchDir mgr (takeDirectory path) _ <- watchDir mgr (takeDirectory path)
(matchesFile path) (matchesFile path)
(handleReload manager) (handleReload manager)
return $ Right manager return $ Right manager
where where
matchesFile target event = target == eventPath event matchesFile target event = target == eventPath event
@ -444,27 +444,27 @@ handleReload manager event = do
-- Save current as last valid -- Save current as last valid
current <- readIORef (currentConfig manager) current <- readIORef (currentConfig manager)
writeIORef (lastValidConfig manager) current writeIORef (lastValidConfig manager) current
-- Atomic swap to new config -- Atomic swap to new config
atomicWriteIORef (currentConfig manager) newConfig atomicWriteIORef (currentConfig manager) newConfig
logInfo "Config reloaded successfully" logInfo "Config reloaded successfully"
else else
logError "Validation failed, keeping old config" logError "Validation failed, keeping old config"
Left err -> do Left err -> do
logError $ "Reload failed: " ++ err logError $ "Reload failed: " ++ err
-- Keep running with old config -- Keep running with old config
where where
tryReload :: FilePath -> IO (Either String AppConfig) tryReload :: FilePath -> IO (Either String AppConfig)
tryReload path = tryReload path =
catch (eitherDecodeFileStrict path) catch (eitherDecodeFileStrict path)
(\(e :: SomeException) -> return $ Left $ show e) (\(e :: SomeException) -> return $ Left $ show e)
validateConfig :: AppConfig -> Bool validateConfig :: AppConfig -> Bool
validateConfig cfg = validateConfig cfg =
-- Custom validation logic -- Custom validation logic
not (null $ apiKeys cfg) not (null $ apiKeys cfg)
&& all isValidEndpoint (databaseEndpoints $ database cfg) && all isValidEndpoint (databaseEndpoints $ database cfg)
-- Access config safely from multiple threads -- Access config safely from multiple threads
@ -484,7 +484,7 @@ debounceReload :: IORef UTCTime -> NominalDiffTime -> IO () -> IO ()
debounceReload lastReloadRef minInterval action = do debounceReload lastReloadRef minInterval action = do
now <- getCurrentTime now <- getCurrentTime
lastReload <- readIORef lastReloadRef lastReload <- readIORef lastReloadRef
when (diffUTCTime now lastReload > minInterval) $ do when (diffUTCTime now lastReload > minInterval) $ do
writeIORef lastReloadRef now writeIORef lastReloadRef now
action action
@ -502,7 +502,7 @@ data DatabasePool = DatabasePool
rotatePoolCredentials :: DatabasePool -> Credentials -> IO () rotatePoolCredentials :: DatabasePool -> Credentials -> IO ()
rotatePoolCredentials dbPool newCreds = do rotatePoolCredentials dbPool newCreds = do
atomicWriteIORef (credentials dbPool) newCreds atomicWriteIORef (credentials dbPool) newCreds
-- Drain old connections gradually -- Drain old connections gradually
-- New connections use new credentials from IORef -- New connections use new credentials from IORef
drainPool (pool dbPool) gracefulDrainSeconds drainPool (pool dbPool) gracefulDrainSeconds
@ -556,7 +556,7 @@ loadConfigFailFast path = do
```haskell ```haskell
import Data.Validation import Data.Validation
data ValidationError = data ValidationError =
InvalidPort Int InvalidPort Int
| MissingField Text | MissingField Text
| InvalidFormat Text Text | InvalidFormat Text Text
@ -571,7 +571,7 @@ validateConfig raw = Config
validatePort p validatePort p
| p > 0 && p < 65536 = Success p | p > 0 && p < 65536 = Success p
| otherwise = Failure [InvalidPort p] | otherwise = Failure [InvalidPort p]
validateHost h validateHost h
| not (T.null h) = Success h | not (T.null h) = Success h
| otherwise = Failure [MissingField "host"] | otherwise = Failure [MissingField "host"]
@ -595,23 +595,23 @@ loadConfigGraceful path = do
Left err -> do Left err -> do
logWarning $ "Config parse error, using defaults: " ++ err logWarning $ "Config parse error, using defaults: " ++ err
return defaultConfig return defaultConfig
Right rawConfig -> do Right rawConfig -> do
-- Core settings must be valid -- Core settings must be valid
core <- case validateCore rawConfig of core <- case validateCore rawConfig of
Left errors -> error $ "Core config invalid: " ++ show errors Left errors -> error $ "Core config invalid: " ++ show errors
Right validated -> return validated Right validated -> return validated
-- Optional features use defaults on error -- Optional features use defaults on error
features <- case validateFeatures rawConfig of features <- case validateFeatures rawConfig of
Left errors -> do Left errors -> do
logWarning $ "Feature config invalid, using defaults: " ++ show errors logWarning $ "Feature config invalid, using defaults: " ++ show errors
return defaultFeatures return defaultFeatures
Right validated -> return validated Right validated -> return validated
-- Experimental flags filter out invalid entries -- Experimental flags filter out invalid entries
let flags = filterValidFlags (rawExperimental rawConfig) let flags = filterValidFlags (rawExperimental rawConfig)
return $ ConfigWithDefaults core features flags return $ ConfigWithDefaults core features flags
``` ```
@ -656,15 +656,15 @@ instance FromJSON ServerConfig where
rawPort <- o .: "port" rawPort <- o .: "port"
when (rawPort < 1 || rawPort > 65535) $ when (rawPort < 1 || rawPort > 65535) $
fail $ "Invalid port: " ++ show rawPort fail $ "Invalid port: " ++ show rawPort
host <- o .: "host" host <- o .: "host"
when (T.null host) $ when (T.null host) $
fail "Host cannot be empty" fail "Host cannot be empty"
workers <- o .:? "workers" .!= 4 -- Default to 4 workers <- o .:? "workers" .!= 4 -- Default to 4
when (workers < 1 || workers > 1000) $ when (workers < 1 || workers > 1000) $
fail $ "Invalid worker count: " ++ show workers fail $ "Invalid worker count: " ++ show workers
return $ ServerConfig rawPort host workers return $ ServerConfig rawPort host workers
``` ```
@ -729,9 +729,9 @@ interpolateEnvVars template = do
let varName = T.drop 2 $ T.dropEnd 1 match -- Strip ${ } let varName = T.drop 2 $ T.dropEnd 1 match -- Strip ${ }
maybeValue <- lookupEnv (T.unpack varName) maybeValue <- lookupEnv (T.unpack varName)
case maybeValue of case maybeValue of
Just value -> Just value ->
return $ Right $ T.replace match (T.pack value) txt return $ Right $ T.replace match (T.pack value) txt
Nothing -> Nothing ->
return $ Left $ "Undefined variable: " ++ T.unpack varName return $ Left $ "Undefined variable: " ++ T.unpack varName
-- With defaults -- With defaults
@ -755,7 +755,7 @@ import System.Envy
data AppConfig = AppConfig data AppConfig = AppConfig
{ appDatabaseUrl :: String -- DATABASE_URL { appDatabaseUrl :: String -- DATABASE_URL
, appRedisHost :: String -- REDIS_HOST , appRedisHost :: String -- REDIS_HOST
, appPort :: Int -- PORT , appPort :: Int -- PORT
, appDebug :: Bool -- DEBUG , appDebug :: Bool -- DEBUG
, appLogLevel :: Maybe LogLevel -- LOG_LEVEL (optional) , appLogLevel :: Maybe LogLevel -- LOG_LEVEL (optional)
@ -787,9 +787,9 @@ main = do
import Options.Applicative import Options.Applicative
import qualified Data.Yaml as Y import qualified Data.Yaml as Y
data ConfigSource = data ConfigSource =
CLIConfig Config CLIConfig Config
| EnvConfig Config | EnvConfig Config
| FileConfig Config | FileConfig Config
| DefaultConfig Config | DefaultConfig Config
@ -804,7 +804,7 @@ mergeConfigs sources = foldl merge defaultConfig sources
merge base (EnvConfig env) = base { port = port env `orDefault` port base } merge base (EnvConfig env) = base { port = port env `orDefault` port base }
merge base (FileConfig file) = base { port = port file `orDefault` port base } merge base (FileConfig file) = base { port = port file `orDefault` port base }
merge base (DefaultConfig _) = base merge base (DefaultConfig _) = base
orDefault :: Maybe a -> a -> a orDefault :: Maybe a -> a -> a
orDefault = fromMaybe orDefault = fromMaybe
@ -813,29 +813,29 @@ loadLayeredConfig :: IO Config
loadLayeredConfig = do loadLayeredConfig = do
-- 1. Load defaults -- 1. Load defaults
let defaults = defaultConfig let defaults = defaultConfig
-- 2. Load system config -- 2. Load system config
systemCfg <- loadSystemConfig `catch` \(_ :: IOException) -> return Nothing systemCfg <- loadSystemConfig `catch` \(_ :: IOException) -> return Nothing
-- 3. Load project config -- 3. Load project config
projectCfg <- loadProjectConfig `catch` \(_ :: IOException) -> return Nothing projectCfg <- loadProjectConfig `catch` \(_ :: IOException) -> return Nothing
-- 4. Load local config -- 4. Load local config
localCfg <- Y.decodeFileEither "config.yaml" >>= \case localCfg <- Y.decodeFileEither "config.yaml" >>= \case
Left _ -> return Nothing Left _ -> return Nothing
Right cfg -> return $ Just cfg Right cfg -> return $ Just cfg
-- 5. Load environment variables -- 5. Load environment variables
envCfg <- decodeEnv :: IO (Either String EnvConfig) envCfg <- decodeEnv :: IO (Either String EnvConfig)
let env = either (const Nothing) Just envCfg let env = either (const Nothing) Just envCfg
-- 6. Parse CLI args -- 6. Parse CLI args
cliCfg <- execParser cliParser cliCfg <- execParser cliParser
-- Merge with precedence -- Merge with precedence
return $ mergeConfigs return $ mergeConfigs
[ maybe DefaultConfig FileConfig systemCfg [ maybe DefaultConfig FileConfig systemCfg
, maybe DefaultConfig FileConfig projectCfg , maybe DefaultConfig FileConfig projectCfg
, maybe DefaultConfig FileConfig localCfg , maybe DefaultConfig FileConfig localCfg
, maybe DefaultConfig EnvConfig env , maybe DefaultConfig EnvConfig env
, CLIConfig cliCfg , CLIConfig cliCfg
@ -852,7 +852,7 @@ newtype SafeEnvValue = SafeEnvValue Text
validateEnvValue :: Text -> Either String SafeEnvValue validateEnvValue :: Text -> Either String SafeEnvValue
validateEnvValue value validateEnvValue value
| T.any isControlChar value = Left "Control characters not allowed" | T.any isControlChar value = Left "Control characters not allowed"
| T.any (== ';') value = Left "Semicolons not allowed" | T.any (== ';') value = Left "Semicolons not allowed"
| T.any (== '|') value = Left "Pipes not allowed" | T.any (== '|') value = Left "Pipes not allowed"
| otherwise = Right $ SafeEnvValue value | otherwise = Right $ SafeEnvValue value
where where
@ -903,10 +903,10 @@ loadSecrets :: VaultConnection -> IO (Either String AppSecrets)
loadSecrets conn = do loadSecrets conn = do
-- Get database credentials -- Get database credentials
dbResult <- getSecret conn (SecretPath "myapp/database") Nothing dbResult <- getSecret conn (SecretPath "myapp/database") Nothing
-- Get API keys -- Get API keys
apiResult <- getSecret conn (SecretPath "myapp/api-keys") Nothing apiResult <- getSecret conn (SecretPath "myapp/api-keys") Nothing
case (dbResult, apiResult) of case (dbResult, apiResult) of
(Right dbData, Right apiData) -> do (Right dbData, Right apiData) -> do
let dbCreds = parseCredentials $ fromSecretData dbData let dbCreds = parseCredentials $ fromSecretData dbData
@ -923,7 +923,7 @@ updateSecret conn = do
NoCheckAndSet NoCheckAndSet
(SecretPath "myapp/database") (SecretPath "myapp/database")
(toSecretData [("password", newPassword), ("username", "admin")]) (toSecretData [("password", newPassword), ("username", "admin")])
case result of case result of
Right version -> putStrLn $ "Updated to version " ++ show version Right version -> putStrLn $ "Updated to version " ++ show version
Left err -> putStrLn $ "Update failed: " ++ err Left err -> putStrLn $ "Update failed: " ++ err
@ -966,14 +966,14 @@ loadDatabaseConfig :: IO (Either String DatabaseConfig)
loadDatabaseConfig = do loadDatabaseConfig = do
-- Discover credentials (IAM role, env vars, etc.) -- Discover credentials (IAM role, env vars, etc.)
env <- newEnv discover env <- newEnv discover
-- Request secret -- Request secret
let req = newGetSecretValue "production/database" let req = newGetSecretValue "production/database"
resp <- runResourceT $ send env req resp <- runResourceT $ send env req
-- Extract and parse -- Extract and parse
case resp ^. getSecretValueResponse_secretString of case resp ^. getSecretValueResponse_secretString of
Just jsonString -> Just jsonString ->
case A.eitherDecode (encodeUtf8 jsonString) of case A.eitherDecode (encodeUtf8 jsonString) of
Right config -> return $ Right config Right config -> return $ Right config
Left err -> return $ Left $ "Parse error: " ++ err Left err -> return $ Left $ "Parse error: " ++ err
@ -983,13 +983,13 @@ loadDatabaseConfig = do
rotateSecret :: Text -> IO () rotateSecret :: Text -> IO ()
rotateSecret secretId = do rotateSecret secretId = do
env <- newEnv discover env <- newEnv discover
let req = newRotateSecret secretId let req = newRotateSecret secretId
& rotateSecret_rotationLambdaARN ?~ lambdaArn & rotateSecret_rotationLambdaARN ?~ lambdaArn
& rotateSecret_rotationRules ?~ & rotateSecret_rotationRules ?~
newRotationRulesType newRotationRulesType
& rotationRulesType_automaticallyAfterDays ?~ 30 & rotationRulesType_automaticallyAfterDays ?~ 30
_ <- runResourceT $ send env req _ <- runResourceT $ send env req
putStrLn "Rotation initiated" putStrLn "Rotation initiated"
``` ```
@ -1038,7 +1038,7 @@ withRotatingCreds rc action = do
Just prev -> action prev -- Fallback during rotation window Just prev -> action prev -- Fallback during rotation window
Nothing -> throwIO RotationError Nothing -> throwIO RotationError
where where
tryAction creds = tryAction creds =
catch (Right <$> action creds) catch (Right <$> action creds)
(\(e :: SomeException) -> return $ Left e) (\(e :: SomeException) -> return $ Left e)
@ -1047,22 +1047,22 @@ rotationLoop :: IORef RotatingCredentials -> VaultConnection -> IO ()
rotationLoop credsRef vault = forever $ do rotationLoop credsRef vault = forever $ do
currentTime <- getCurrentTime currentTime <- getCurrentTime
creds <- readIORef credsRef creds <- readIORef credsRef
when (shouldRotate currentTime (rotationTime creds)) $ do when (shouldRotate currentTime (rotationTime creds)) $ do
-- Fetch new credentials -- Fetch new credentials
newCreds <- fetchDynamicCreds vault newCreds <- fetchDynamicCreds vault
-- Update with both old and new -- Update with both old and new
atomicModifyIORef' credsRef $ \old -> atomicModifyIORef' credsRef $ \old ->
(RotatingCredentials newCreds (Just $ currentCreds old) currentTime, ()) (RotatingCredentials newCreds (Just $ currentCreds old) currentTime, ())
threadDelay (5 * 60 * 1000000) -- Check every 5 minutes threadDelay (5 * 60 * 1000000) -- Check every 5 minutes
-- Vault dynamic secrets with lease renewal -- Vault dynamic secrets with lease renewal
requestDynamicCredentials :: VaultConnection -> IO DynamicDBCredentials requestDynamicCredentials :: VaultConnection -> IO DynamicDBCredentials
requestDynamicCredentials conn = do requestDynamicCredentials conn = do
result <- vaultRead conn (VaultSecretPath "database/creds/readonly") result <- vaultRead conn (VaultSecretPath "database/creds/readonly")
case result of case result of
(metadata, Right creds) -> do (metadata, Right creds) -> do
-- Schedule renewal before expiration -- Schedule renewal before expiration
@ -1074,7 +1074,7 @@ renewLeaseLoop :: VaultConnection -> Text -> Int -> IO ()
renewLeaseLoop conn leaseId duration = do renewLeaseLoop conn leaseId duration = do
let renewInterval = duration `div` 2 -- Renew at halfway point let renewInterval = duration `div` 2 -- Renew at halfway point
threadDelay (renewInterval * 1000000) threadDelay (renewInterval * 1000000)
success <- renewLease conn leaseId success <- renewLease conn leaseId
if success if success
then renewLeaseLoop conn leaseId duration -- Continue renewing then renewLeaseLoop conn leaseId duration -- Continue renewing
@ -1086,7 +1086,7 @@ renewLeaseLoop conn leaseId duration = do
```haskell ```haskell
-- Never store secrets in code or config files -- Never store secrets in code or config files
-- ❌ DON'T DO THIS -- ❌ DON'T DO THIS
apiKey = "sk_live_abc123xyz" apiKey = "sk_live_abc123xyz"
-- ✅ Load from secure source -- ✅ Load from secure source
loadSecrets :: IO Secrets loadSecrets :: IO Secrets
@ -1222,12 +1222,12 @@ databaseCodec = DatabaseConfig
```dhall ```dhall
-- types/Database.dhall -- types/Database.dhall
let PoolConfig = { Type = let PoolConfig = { Type =
{ minConnections : Natural { minConnections : Natural
, maxConnections : Natural , maxConnections : Natural
, idleTimeout : Natural , idleTimeout : Natural
} }
, default = , default =
{ minConnections = 5 { minConnections = 5
, maxConnections = 20 , maxConnections = 20
, idleTimeout = 30 , idleTimeout = 30
@ -1259,11 +1259,11 @@ in DatabaseConfig
-- config/production.dhall -- config/production.dhall
let DB = ../types/Database.dhall let DB = ../types/Database.dhall
in DB::{ in DB::{
, host = "prod-db.internal" , host = "prod-db.internal"
, name = "production_db" , name = "production_db"
, pool = DB.default.pool // { maxConnections = 100 } , pool = DB.default.pool // { maxConnections = 100 }
, replicas = , replicas =
[ { host = "replica1.internal", port = 5432 } [ { host = "replica1.internal", port = 5432 }
, { host = "replica2.internal", port = 5432 } , { host = "replica2.internal", port = 5432 }
] ]
@ -1295,12 +1295,12 @@ initFeatureFlags :: FilePath -> IO FeatureFlagManager
initFeatureFlags path = do initFeatureFlags path = do
initial <- loadFeatureFlags path initial <- loadFeatureFlags path
flagsRef <- newIORef initial flagsRef <- newIORef initial
let manager = FeatureFlagManager flagsRef path let manager = FeatureFlagManager flagsRef path
-- Watch for changes -- Watch for changes
_ <- forkIO $ watchAndReload manager _ <- forkIO $ watchAndReload manager
return manager return manager
where where
loadFeatureFlags :: FilePath -> IO FeatureFlags loadFeatureFlags :: FilePath -> IO FeatureFlags
@ -1359,25 +1359,25 @@ loadConfig = do
Just "production" -> Production Just "production" -> Production
Just "staging" -> Staging Just "staging" -> Staging
_ -> Development _ -> Development
-- Load shared config -- Load shared config
shared <- decodeFileThrow "config/shared.yaml" shared <- decodeFileThrow "config/shared.yaml"
-- Load environment-specific config -- Load environment-specific config
let envFile = case env of let envFile = case env of
Development -> "config/development.yaml" Development -> "config/development.yaml"
Staging -> "config/staging.yaml" Staging -> "config/staging.yaml"
Production -> "config/production.yaml" Production -> "config/production.yaml"
envSpecific <- decodeFileThrow envFile envSpecific <- decodeFileThrow envFile
-- Merge with env vars (highest precedence) -- Merge with env vars (highest precedence)
envOverrides <- decodeEnv :: IO (Either String EnvOverrides) envOverrides <- decodeEnv :: IO (Either String EnvOverrides)
let finalConfig = case envOverrides of let finalConfig = case envOverrides of
Right overrides -> applyOverrides envSpecific overrides Right overrides -> applyOverrides envSpecific overrides
Left _ -> envSpecific Left _ -> envSpecific
return $ MultiEnvConfig shared env finalConfig return $ MultiEnvConfig shared env finalConfig
``` ```
@ -1424,7 +1424,7 @@ handleReload event = do
result <- try $ decodeFile path result <- try $ decodeFile path
case result of case result of
Right newConfig -> atomicWriteIORef configRef newConfig Right newConfig -> atomicWriteIORef configRef newConfig
Left (err :: SomeException) -> Left (err :: SomeException) ->
logError $ "Reload failed, keeping old config: " ++ show err logError $ "Reload failed, keeping old config: " ++ show err
``` ```
@ -1496,7 +1496,7 @@ let baseService = ./types/Service.dhall
let makeServiceConfig = λ(name : Text) → λ(port : Natural) → let makeServiceConfig = λ(name : Text) → λ(port : Natural) →
baseService::{ name = name, port = port } baseService::{ name = name, port = port }
in { services = in { services =
[ makeServiceConfig "api" 8080 [ makeServiceConfig "api" 8080
, makeServiceConfig "auth" 8081 , makeServiceConfig "auth" 8081
-- ... 48 more services with consistent structure -- ... 48 more services with consistent structure

View File

@ -189,16 +189,16 @@ Nginx's event-based architecture provides inherent resistance to connection exha
http { http {
# Time to read client request header # Time to read client request header
client_header_timeout 10s; client_header_timeout 10s;
# Time between successive body data reads # Time between successive body data reads
client_body_timeout 10s; client_body_timeout 10s;
# Keep-alive connection timeout # Keep-alive connection timeout
keepalive_timeout 15s; keepalive_timeout 15s;
# Time between successive writes to client # Time between successive writes to client
send_timeout 10s; send_timeout 10s;
# Buffer limits prevent memory exhaustion # Buffer limits prevent memory exhaustion
client_body_buffer_size 128k; client_body_buffer_size 128k;
client_header_buffer_size 2k; client_header_buffer_size 2k;
@ -228,19 +228,19 @@ LoadModule qos_module modules/mod_qos.so
<IfModule mod_qos.c> <IfModule mod_qos.c>
# Track 500,000 unique client IPs (150 bytes per entry) # Track 500,000 unique client IPs (150 bytes per entry)
QS_ClientEntries 500000 QS_ClientEntries 500000
# Maximum 20 concurrent connections per IP # Maximum 20 concurrent connections per IP
QS_SrvMaxConnPerIP 20 QS_SrvMaxConnPerIP 20
# Maximum 512 total active connections # Maximum 512 total active connections
QS_SrvMaxConn 512 QS_SrvMaxConn 512
# Disable keep-alive when 400 connections active # Disable keep-alive when 400 connections active
QS_SrvMaxConnClose 400 QS_SrvMaxConnClose 400
# Minimum data rates: 200 bytes/sec download, 1500 upload # Minimum data rates: 200 bytes/sec download, 1500 upload
QS_SrvMinDataRate 200 1500 QS_SrvMinDataRate 200 1500
# Protect resource-intensive endpoints # Protect resource-intensive endpoints
QS_LocRequestLimit "/login" 5 QS_LocRequestLimit "/login" 5
QS_LocRequestLimit "/admin" 3 QS_LocRequestLimit "/admin" 3
@ -264,15 +264,15 @@ http {
limit_conn_zone $binary_remote_addr zone=addr:10m; limit_conn_zone $binary_remote_addr zone=addr:10m;
limit_req_zone $binary_remote_addr zone=general:10m rate=10r/s; limit_req_zone $binary_remote_addr zone=general:10m rate=10r/s;
limit_req_zone $binary_remote_addr zone=login:10m rate=1r/s; limit_req_zone $binary_remote_addr zone=login:10m rate=1r/s;
server { server {
# Global: 10 concurrent connections per IP # Global: 10 concurrent connections per IP
limit_conn addr 10; limit_conn addr 10;
location / { location / {
limit_req zone=general burst=20 nodelay; limit_req zone=general burst=20 nodelay;
} }
location /login { location /login {
# Aggressive limits for authentication # Aggressive limits for authentication
limit_conn addr 3; limit_conn addr 3;
@ -521,20 +521,20 @@ SEC("xdp")
int ddos_protection(struct xdp_md *ctx) { int ddos_protection(struct xdp_md *ctx) {
void *data_end = (void *)(long)ctx->data_end; void *data_end = (void *)(long)ctx->data_end;
void *data = (void *)(long)ctx->data; void *data = (void *)(long)ctx->data;
// Parse Ethernet header // Parse Ethernet header
struct ethhdr *eth = data; struct ethhdr *eth = data;
if ((void *)(eth + 1) > data_end) return XDP_PASS; if ((void *)(eth + 1) > data_end) return XDP_PASS;
if (eth->h_proto != __constant_htons(ETH_P_IP)) return XDP_PASS; if (eth->h_proto != __constant_htons(ETH_P_IP)) return XDP_PASS;
// Parse IP header // Parse IP header
struct iphdr *iph = (void *)(eth + 1); struct iphdr *iph = (void *)(eth + 1);
if ((void *)(iph + 1) > data_end) return XDP_PASS; if ((void *)(iph + 1) > data_end) return XDP_PASS;
__u32 src_ip = iph->saddr; __u32 src_ip = iph->saddr;
struct rate_limit_entry *entry = bpf_map_lookup_elem(&rate_limit_map, &src_ip); struct rate_limit_entry *entry = bpf_map_lookup_elem(&rate_limit_map, &src_ip);
__u64 current_time = bpf_ktime_get_ns(); __u64 current_time = bpf_ktime_get_ns();
if (entry) { if (entry) {
if (current_time - entry->last_update < TIME_WINDOW_NS) { if (current_time - entry->last_update < TIME_WINDOW_NS) {
entry->packet_count++; entry->packet_count++;
@ -1099,7 +1099,7 @@ groups:
for: 2m for: 2m
annotations: annotations:
summary: "High SYN rate detected" summary: "High SYN rate detected"
- alert: ConntrackTableFull - alert: ConntrackTableFull
expr: node_nf_conntrack_entries / node_nf_conntrack_entries_limit > 0.9 expr: node_nf_conntrack_entries / node_nf_conntrack_entries_limit > 0.9
for: 5m for: 5m

View File

@ -269,14 +269,14 @@ For complex dependencies, Nix provides reproducible static builds.
let let
pkgs = import <nixpkgs> {}; pkgs = import <nixpkgs> {};
pkgsMusl = pkgs.pkgsMusl; pkgsMusl = pkgs.pkgsMusl;
staticLibs = [ staticLibs = [
(pkgsMusl.gmp6.override { withStatic = true; }) (pkgsMusl.gmp6.override { withStatic = true; })
pkgsMusl.zlib.static pkgsMusl.zlib.static
(pkgsMusl.libffi.overrideAttrs (old: { dontDisableStatic = true; })) (pkgsMusl.libffi.overrideAttrs (old: { dontDisableStatic = true; }))
(pkgsMusl.openssl.override { static = true; }) (pkgsMusl.openssl.override { static = true; })
]; ];
in pkgsMusl.haskellPackages.aenebris.overrideAttrs (old: { in pkgsMusl.haskellPackages.aenebris.overrideAttrs (old: {
enableSharedExecutables = false; enableSharedExecutables = false;
enableSharedLibraries = false; enableSharedLibraries = false;
@ -384,7 +384,7 @@ packages: .
package * package *
ghc-options: -O2 -split-sections ghc-options: -O2 -split-sections
gcc-options: -Os -ffunction-sections -fdata-sections gcc-options: -Os -ffunction-sections -fdata-sections
package aenebris package aenebris
ld-options: -Wl,--gc-sections ld-options: -Wl,--gc-sections
ghc-options: -funbox-strict-fields -fllvm ghc-options: -funbox-strict-fields -fllvm
@ -442,13 +442,13 @@ spec:
spec: spec:
# Service account for RBAC # Service account for RBAC
serviceAccountName: aenebris serviceAccountName: aenebris
# Security context # Security context
securityContext: securityContext:
runAsNonRoot: true runAsNonRoot: true
runAsUser: 1000 runAsUser: 1000
fsGroup: 1000 fsGroup: 1000
# Topology spread for high availability # Topology spread for high availability
topologySpreadConstraints: topologySpreadConstraints:
- maxSkew: 1 - maxSkew: 1
@ -463,7 +463,7 @@ spec:
labelSelector: labelSelector:
matchLabels: matchLabels:
app: aenebris app: aenebris
# Node affinity for dedicated nodes # Node affinity for dedicated nodes
affinity: affinity:
nodeAffinity: nodeAffinity:
@ -474,7 +474,7 @@ spec:
- key: workload-type - key: workload-type
operator: In operator: In
values: [proxy, edge] values: [proxy, edge]
# Pod anti-affinity # Pod anti-affinity
podAntiAffinity: podAntiAffinity:
preferredDuringSchedulingIgnoredDuringExecution: preferredDuringSchedulingIgnoredDuringExecution:
@ -484,15 +484,15 @@ spec:
matchLabels: matchLabels:
app: aenebris app: aenebris
topologyKey: kubernetes.io/hostname topologyKey: kubernetes.io/hostname
# Graceful shutdown - CRITICAL for WebSockets # Graceful shutdown - CRITICAL for WebSockets
terminationGracePeriodSeconds: 120 terminationGracePeriodSeconds: 120
containers: containers:
- name: aenebris - name: aenebris
image: ghcr.io/yourorg/aenebris:1.0.0 image: ghcr.io/yourorg/aenebris:1.0.0
imagePullPolicy: IfNotPresent imagePullPolicy: IfNotPresent
# Ports # Ports
ports: ports:
- name: http - name: http
@ -504,7 +504,7 @@ spec:
- name: metrics - name: metrics
containerPort: 9090 containerPort: 9090
protocol: TCP protocol: TCP
# Haskell RTS configuration for high performance # Haskell RTS configuration for high performance
command: command:
- /usr/local/bin/aenebris - /usr/local/bin/aenebris
@ -519,14 +519,14 @@ spec:
- "-RTS" - "-RTS"
- "--config" - "--config"
- "/etc/aenebris/config.yaml" - "/etc/aenebris/config.yaml"
# Environment variables # Environment variables
env: env:
- name: LOG_LEVEL - name: LOG_LEVEL
value: "info" value: "info"
- name: METRICS_PORT - name: METRICS_PORT
value: "9090" value: "9090"
# Resource requests and limits # Resource requests and limits
resources: resources:
requests: requests:
@ -535,7 +535,7 @@ spec:
limits: limits:
cpu: "8000m" # Burst to 8 cores cpu: "8000m" # Burst to 8 cores
memory: "4Gi" # Hard limit memory: "4Gi" # Hard limit
# Volume mounts # Volume mounts
volumeMounts: volumeMounts:
- name: config - name: config
@ -549,7 +549,7 @@ spec:
readOnly: true readOnly: true
- name: tmp - name: tmp
mountPath: /tmp mountPath: /tmp
# Startup probe (slow initial startup) # Startup probe (slow initial startup)
startupProbe: startupProbe:
httpGet: httpGet:
@ -561,7 +561,7 @@ spec:
timeoutSeconds: 1 timeoutSeconds: 1
failureThreshold: 30 # 60 seconds max startup time failureThreshold: 30 # 60 seconds max startup time
successThreshold: 1 successThreshold: 1
# Liveness probe (detect deadlocks) # Liveness probe (detect deadlocks)
livenessProbe: livenessProbe:
httpGet: httpGet:
@ -573,7 +573,7 @@ spec:
timeoutSeconds: 2 timeoutSeconds: 2
failureThreshold: 3 failureThreshold: 3
successThreshold: 1 successThreshold: 1
# Readiness probe (traffic management) # Readiness probe (traffic management)
readinessProbe: readinessProbe:
httpGet: httpGet:
@ -585,7 +585,7 @@ spec:
timeoutSeconds: 2 timeoutSeconds: 2
failureThreshold: 2 failureThreshold: 2
successThreshold: 1 successThreshold: 1
# PreStop hook for graceful shutdown # PreStop hook for graceful shutdown
lifecycle: lifecycle:
preStop: preStop:
@ -599,7 +599,7 @@ spec:
kill -TERM 1 kill -TERM 1
# Wait for connections to drain (110s, leaving 10s buffer) # Wait for connections to drain (110s, leaving 10s buffer)
sleep 110 sleep 110
# Security context # Security context
securityContext: securityContext:
allowPrivilegeEscalation: false allowPrivilegeEscalation: false
@ -609,7 +609,7 @@ spec:
capabilities: capabilities:
drop: ["ALL"] drop: ["ALL"]
add: ["NET_BIND_SERVICE"] add: ["NET_BIND_SERVICE"]
volumes: volumes:
- name: config - name: config
configMap: configMap:
@ -683,7 +683,7 @@ spec:
target: target:
type: Utilization type: Utilization
averageUtilization: 70 averageUtilization: 70
# Memory-based scaling # Memory-based scaling
- type: Resource - type: Resource
resource: resource:
@ -691,7 +691,7 @@ spec:
target: target:
type: Utilization type: Utilization
averageUtilization: 80 averageUtilization: 80
# Custom metric: requests per second # Custom metric: requests per second
- type: Pods - type: Pods
pods: pods:
@ -700,7 +700,7 @@ spec:
target: target:
type: AverageValue type: AverageValue
averageValue: "2000" # 2k req/s per pod averageValue: "2000" # 2k req/s per pod
# Custom metric: active connections # Custom metric: active connections
- type: Pods - type: Pods
pods: pods:
@ -709,7 +709,7 @@ spec:
target: target:
type: AverageValue type: AverageValue
averageValue: "1000" # 1k connections per pod averageValue: "1000" # 1k connections per pod
# Scaling behavior # Scaling behavior
behavior: behavior:
scaleUp: scaleUp:
@ -971,7 +971,7 @@ probes:
timeoutSeconds: 1 timeoutSeconds: 1
failureThreshold: 30 failureThreshold: 30
successThreshold: 1 successThreshold: 1
liveness: liveness:
httpGet: httpGet:
path: /healthz path: /healthz
@ -981,7 +981,7 @@ probes:
timeoutSeconds: 2 timeoutSeconds: 2
failureThreshold: 3 failureThreshold: 3
successThreshold: 1 successThreshold: 1
readiness: readiness:
httpGet: httpGet:
path: /ready path: /ready
@ -1009,12 +1009,12 @@ config:
enabled: true enabled: true
path: "/health" path: "/health"
interval: "10s" interval: "10s"
rateLimit: rateLimit:
enabled: true enabled: true
requestsPerSecond: 1000 requestsPerSecond: 1000
burst: 2000 burst: 2000
tls: tls:
enabled: true enabled: true
minVersion: "1.2" minVersion: "1.2"
@ -1022,7 +1022,7 @@ config:
- "TLS_AES_256_GCM_SHA384" - "TLS_AES_256_GCM_SHA384"
- "TLS_AES_128_GCM_SHA256" - "TLS_AES_128_GCM_SHA256"
- "TLS_CHACHA20_POLY1305_SHA256" - "TLS_CHACHA20_POLY1305_SHA256"
websocket: websocket:
enabled: true enabled: true
pingInterval: "30s" pingInterval: "30s"
@ -1041,7 +1041,7 @@ tls:
secrets: secrets:
upstreamCredentials: upstreamCredentials:
existingSecret: "aenebris-upstream-creds" existingSecret: "aenebris-upstream-creds"
# Network policies # Network policies
networkPolicy: networkPolicy:
enabled: true enabled: true
@ -1496,7 +1496,7 @@ spec:
timeoutSeconds: 1 timeoutSeconds: 1
failureThreshold: 30 # 5s + (30 * 2s) = 65s max failureThreshold: 30 # 5s + (30 * 2s) = 65s max
successThreshold: 1 successThreshold: 1
# Liveness probe - detects deadlocks # Liveness probe - detects deadlocks
livenessProbe: livenessProbe:
httpGet: httpGet:
@ -1511,7 +1511,7 @@ spec:
timeoutSeconds: 2 timeoutSeconds: 2
failureThreshold: 3 # Restart after 30s of failures failureThreshold: 3 # Restart after 30s of failures
successThreshold: 1 successThreshold: 1
# Readiness probe - traffic management # Readiness probe - traffic management
readinessProbe: readinessProbe:
httpGet: httpGet:
@ -1541,15 +1541,15 @@ lifecycle:
- | - |
# Stop accepting new connections # Stop accepting new connections
echo "Graceful shutdown initiated at $(date)" echo "Graceful shutdown initiated at $(date)"
# Send SIGTERM to application (it should stop accepting) # Send SIGTERM to application (it should stop accepting)
kill -TERM 1 kill -TERM 1
# Wait for existing connections to drain # Wait for existing connections to drain
# (110 seconds, leaving 10s buffer before SIGKILL) # (110 seconds, leaving 10s buffer before SIGKILL)
echo "Waiting for connections to drain..." echo "Waiting for connections to drain..."
sleep 110 sleep 110
echo "Shutdown complete at $(date)" echo "Shutdown complete at $(date)"
``` ```
@ -1575,23 +1575,23 @@ main :: IO ()
main = do main = do
shutdownFlag <- newTVarIO False shutdownFlag <- newTVarIO False
setupGracefulShutdown shutdownFlag setupGracefulShutdown shutdownFlag
-- Start server in separate thread -- Start server in separate thread
serverThread <- async $ runServer shutdownFlag serverThread <- async $ runServer shutdownFlag
-- Wait for shutdown signal -- Wait for shutdown signal
atomically $ do atomically $ do
shutdown <- readTVar shutdownFlag shutdown <- readTVar shutdownFlag
unless shutdown retry unless shutdown retry
putStrLn "Stopping server, draining connections..." putStrLn "Stopping server, draining connections..."
-- Stop accepting new connections -- Stop accepting new connections
stopAcceptingConnections stopAcceptingConnections
-- Wait for existing connections to complete -- Wait for existing connections to complete
waitForConnectionsDrain 110 -- 110 seconds waitForConnectionsDrain 110 -- 110 seconds
putStrLn "All connections drained, exiting" putStrLn "All connections drained, exiting"
waitForConnectionsDrain :: Int -> IO () waitForConnectionsDrain :: Int -> IO ()
@ -1617,10 +1617,10 @@ metadata:
# AWS NLB # AWS NLB
service.beta.kubernetes.io/aws-load-balancer-connection-draining-enabled: "true" service.beta.kubernetes.io/aws-load-balancer-connection-draining-enabled: "true"
service.beta.kubernetes.io/aws-load-balancer-connection-draining-timeout: "120" service.beta.kubernetes.io/aws-load-balancer-connection-draining-timeout: "120"
# GCP # GCP
cloud.google.com/neg: '{"ingress": true}' cloud.google.com/neg: '{"ingress": true}'
spec: spec:
sessionAffinity: ClientIP sessionAffinity: ClientIP
sessionAffinityConfig: sessionAffinityConfig:
@ -1783,7 +1783,7 @@ sum(websocket_connections_total) by (pod)
rate(container_cpu_cfs_throttled_seconds_total{pod=~"aenebris.*"}[5m]) rate(container_cpu_cfs_throttled_seconds_total{pod=~"aenebris.*"}[5m])
# Memory usage vs limit # Memory usage vs limit
container_memory_usage_bytes{pod=~"aenebris.*"} / container_memory_usage_bytes{pod=~"aenebris.*"} /
container_spec_memory_limit_bytes{pod=~"aenebris.*"} container_spec_memory_limit_bytes{pod=~"aenebris.*"}
``` ```
@ -1853,14 +1853,14 @@ kubectl delete certificate aenebris-tls -n production
This comprehensive deployment guide provides a production-ready foundation for deploying Ᾰenebris on Kubernetes. The architecture achieves: This comprehensive deployment guide provides a production-ready foundation for deploying Ᾰenebris on Kubernetes. The architecture achieves:
**Ultra-minimal Docker images** (15-50MB) via multi-stage builds and static linking **Ultra-minimal Docker images** (15-50MB) via multi-stage builds and static linking
**High availability** with topology spread, pod disruption budgets, and anti-affinity **High availability** with topology spread, pod disruption budgets, and anti-affinity
**Zero-downtime deployments** through graceful shutdown and connection draining **Zero-downtime deployments** through graceful shutdown and connection draining
**Automated TLS management** with cert-manager **Automated TLS management** with cert-manager
**Secure secrets handling** via External Secrets Operator and Sealed Secrets **Secure secrets handling** via External Secrets Operator and Sealed Secrets
**Production-grade monitoring** with Prometheus and Grafana **Production-grade monitoring** with Prometheus and Grafana
**Dynamic scaling** from 5 to 50 replicas based on traffic **Dynamic scaling** from 5 to 50 replicas based on traffic
**WebSocket support** with proper connection management **WebSocket support** with proper connection management
**Next Steps:** **Next Steps:**
1. Customize values.yaml for your environment 1. Customize values.yaml for your environment

View File

@ -194,7 +194,7 @@ bingExample = do
### WaiProxyResponse type ### WaiProxyResponse type
```haskell ```haskell
data WaiProxyResponse data WaiProxyResponse
= WPRResponse WAI.Response -- Return custom response = WPRResponse WAI.Response -- Return custom response
| WPRProxyDest ProxyDest -- Forward to destination | WPRProxyDest ProxyDest -- Forward to destination
| WPRModifiedRequest WAI.Request ProxyDest -- Modify then forward | WPRModifiedRequest WAI.Request ProxyDest -- Modify then forward
@ -245,7 +245,7 @@ proxyApp manager request respond = do
else give chunk >> loop else give chunk >> loop
in loop in loop
} }
-- Make the request and forward response -- Make the request and forward response
httpLbs proxiedReq manager >>= \response -> httpLbs proxiedReq manager >>= \response ->
respond $ responseLBS respond $ responseLBS
@ -257,7 +257,7 @@ proxyApp manager request respond = do
fixHeaders :: RequestHeaders -> RequestHeaders fixHeaders :: RequestHeaders -> RequestHeaders
fixHeaders = filter $ \(name, _) -> name `notElem` hopByHopHeaders fixHeaders = filter $ \(name, _) -> name `notElem` hopByHopHeaders
where where
hopByHopHeaders = hopByHopHeaders =
[ "connection", "keep-alive", "proxy-authenticate" [ "connection", "keep-alive", "proxy-authenticate"
, "proxy-authorization", "te", "trailers" , "proxy-authorization", "te", "trailers"
, "transfer-encoding", "upgrade" , "transfer-encoding", "upgrade"
@ -266,7 +266,7 @@ fixHeaders = filter $ \(name, _) -> name `notElem` hopByHopHeaders
fixResponseHeaders :: ResponseHeaders -> ResponseHeaders fixResponseHeaders :: ResponseHeaders -> ResponseHeaders
fixResponseHeaders = filter $ \(name, _) -> name `notElem` hopByHopHeaders fixResponseHeaders = filter $ \(name, _) -> name `notElem` hopByHopHeaders
where where
hopByHopHeaders = hopByHopHeaders =
[ "connection", "keep-alive", "proxy-authenticate" [ "connection", "keep-alive", "proxy-authenticate"
, "proxy-authorization", "te", "trailers" , "proxy-authorization", "te", "trailers"
, "transfer-encoding", "upgrade" , "transfer-encoding", "upgrade"
@ -286,7 +286,7 @@ main = do
```haskell ```haskell
-- Add X-Forwarded-For header -- Add X-Forwarded-For header
addForwardedFor :: Request -> RequestHeaders -> RequestHeaders addForwardedFor :: Request -> RequestHeaders -> RequestHeaders
addForwardedFor req headers = addForwardedFor req headers =
let clientIP = show (remoteHost req) let clientIP = show (remoteHost req)
existing = lookup "X-Forwarded-For" headers existing = lookup "X-Forwarded-For" headers
newValue = case existing of newValue = case existing of
@ -369,7 +369,7 @@ import Network.HTTP.Types
import Data.ByteString.Builder (byteString) import Data.ByteString.Builder (byteString)
app :: Application app :: Application
app _req respond = respond $ app _req respond = respond $
responseStream status200 [("Content-Type", "text/plain")] $ \write flush -> do responseStream status200 [("Content-Type", "text/plain")] $ \write flush -> do
write $ byteString "Hello\n" write $ byteString "Hello\n"
flush flush
@ -388,10 +388,10 @@ import Data.Function (fix)
import Control.Monad (unless) import Control.Monad (unless)
streamFileApp :: Application streamFileApp :: Application
streamFileApp _req respond = streamFileApp _req respond =
withBinaryFile "largefile.txt" ReadMode $ \h -> withBinaryFile "largefile.txt" ReadMode $ \h ->
respond $ responseStream status200 [("Content-Type", "text/plain")] $ respond $ responseStream status200 [("Content-Type", "text/plain")] $
\chunk _flush -> \chunk _flush ->
fix $ \loop -> do fix $ \loop -> do
bs <- B.hGetSome h 4096 -- Only 4KB in memory at once bs <- B.hGetSome h 4096 -- Only 4KB in memory at once
unless (B.null bs) $ do unless (B.null bs) $ do
@ -414,17 +414,17 @@ import qualified Data.ByteString.Char8 as C8
sseApp :: Application sseApp :: Application
sseApp _req sendResponse = sendResponse $ sseApp _req sendResponse = sendResponse $
responseStream status200 responseStream status200
[("Content-Type", "text/event-stream"), [("Content-Type", "text/event-stream"),
("Cache-Control", "no-cache"), ("Cache-Control", "no-cache"),
("Connection", "keep-alive")] ("Connection", "keep-alive")]
myStream myStream
myStream :: (Builder -> IO ()) -> IO () -> IO () myStream :: (Builder -> IO ()) -> IO () -> IO ()
myStream send flush = do myStream send flush = do
send $ byteString "data: Starting streaming response.\n\n" send $ byteString "data: Starting streaming response.\n\n"
flush flush
forM_ [1..50 :: Int] $ \i -> do forM_ [1..50 :: Int] $ \i -> do
threadDelay 1000000 -- 1 second threadDelay 1000000 -- 1 second
send $ byteString "data: Message " <> byteString (C8.pack $ show i) <> byteString "\n\n" send $ byteString "data: Message " <> byteString (C8.pack $ show i) <> byteString "\n\n"
@ -464,10 +464,10 @@ main = do
-- Pure operations -- Pure operations
result <- runConduit $ yieldMany [1..10] .| sumC result <- runConduit $ yieldMany [1..10] .| sumC
print result -- 55 print result -- 55
-- File operations -- File operations
runConduitRes $ runConduitRes $
sourceFile "input.txt" .| sourceFile "input.txt" .|
sinkFile "output.txt" sinkFile "output.txt"
``` ```
@ -480,8 +480,8 @@ import qualified Data.Conduit.Binary as CB
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
conduitFileApp :: Application conduitFileApp :: Application
conduitFileApp _req respond = conduitFileApp _req respond =
respond $ responseStream status200 [("Content-Type", "text/plain")] $ respond $ responseStream status200 [("Content-Type", "text/plain")] $
\write flush -> runResourceT $ do \write flush -> runResourceT $ do
CB.sourceFile "largefile.txt" $$ CB.mapM_ $ \chunk -> liftIO $ do CB.sourceFile "largefile.txt" $$ CB.mapM_ $ \chunk -> liftIO $ do
write (byteString chunk) write (byteString chunk)
@ -498,8 +498,8 @@ import qualified Data.Conduit.List as CL
streamFromDB :: Handler () streamFromDB :: Handler ()
streamFromDB = do streamFromDB = do
-- selectSource returns a conduit Source -- selectSource returns a conduit Source
selectSource [] [] selectSource [] []
$$ CL.mapM_ $ \(Entity _ record) -> $$ CL.mapM_ $ \(Entity _ record) ->
liftIO $ processRecord record liftIO $ processRecord record
``` ```
@ -531,8 +531,8 @@ import Data.Conduit
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
sumConduit :: IO Int sumConduit :: IO Int
sumConduit = runConduit $ sumConduit = runConduit $
yieldMany [1..10] .| yieldMany [1..10] .|
CL.fold (+) 0 CL.fold (+) 0
``` ```
@ -589,17 +589,17 @@ generateCSV write flush = do
-- Header -- Header
write $ byteString "id,name,value\n" write $ byteString "id,name,value\n"
flush flush
-- Generate 1 million rows without buffering -- Generate 1 million rows without buffering
forM_ [1..1000000] $ \i -> do forM_ [1..1000000] $ \i -> do
let row = byteString $ C8.pack $ let row = byteString $ C8.pack $
show i ++ ",Item" ++ show i ++ "," ++ show (i * 100) ++ "\n" show i ++ ",Item" ++ show i ++ "," ++ show (i * 100) ++ "\n"
write row write row
when (i `mod` 1000 == 0) flush when (i `mod` 1000 == 0) flush
csvApp :: Application csvApp :: Application
csvApp _req respond = respond $ csvApp _req respond = respond $
responseStream status200 responseStream status200
[("Content-Type", "text/csv"), [("Content-Type", "text/csv"),
("Content-Disposition", "attachment; filename=data.csv")] ("Content-Disposition", "attachment; filename=data.csv")]
generateCSV generateCSV
@ -611,19 +611,19 @@ csvApp _req respond = respond $
processWithProgress :: (Builder -> IO ()) -> IO () -> IO () processWithProgress :: (Builder -> IO ()) -> IO () -> IO ()
processWithProgress write flush = do processWithProgress write flush = do
let total = 100 let total = 100
forM_ [1..total] $ \i -> do forM_ [1..total] $ \i -> do
threadDelay 100000 -- Simulate work threadDelay 100000 -- Simulate work
let progress = byteString $ let progress = byteString $
"data: {\"progress\": " <> "data: {\"progress\": " <>
byteString (C8.pack $ show i) <> byteString (C8.pack $ show i) <>
", \"total\": " <> ", \"total\": " <>
byteString (C8.pack $ show total) <> byteString (C8.pack $ show total) <>
"}\n\n" "}\n\n"
write progress write progress
flush flush
write $ byteString "data: {\"status\": \"complete\"}\n\n" write $ byteString "data: {\"status\": \"complete\"}\n\n"
flush flush
``` ```
@ -725,7 +725,7 @@ application state pending = do
client = (T.drop (T.length prefix) msg, conn) client = (T.drop (T.length prefix) msg, conn)
disconnect = do disconnect = do
s <- modifyMVar state $ \s -> s <- modifyMVar state $ \s ->
let s' = filter ((/= fst client) . fst) s let s' = filter ((/= fst client) . fst) s
in return (s', s') in return (s', s')
broadcast (fst client <> " disconnected") s broadcast (fst client <> " disconnected") s
@ -798,9 +798,9 @@ advancedTLS = do
} }
, onInsecure = DenyInsecure "This server requires HTTPS" , onInsecure = DenyInsecure "This server requires HTTPS"
} }
warpOpts = setPort 443 $ setHost "0.0.0.0" $ defaultSettings warpOpts = setPort 443 $ setHost "0.0.0.0" $ defaultSettings
runTLS tlsOpts warpOpts app runTLS tlsOpts warpOpts app
validateClientCert :: CertificateChain -> IO CertificateUsage validateClientCert :: CertificateChain -> IO CertificateUsage
@ -821,7 +821,7 @@ secureTLS = do
let tlsOpts = tlsSettings "cert.pem" "key.pem" let tlsOpts = tlsSettings "cert.pem" "key.pem"
warpOpts = setPort 443 defaultSettings warpOpts = setPort 443 defaultSettings
wsApp = websocketsOr WS.defaultConnectionOptions wsHandler httpApp wsApp = websocketsOr WS.defaultConnectionOptions wsHandler httpApp
runTLS tlsOpts warpOpts wsApp runTLS tlsOpts warpOpts wsApp
wsHandler :: WS.ServerApp wsHandler :: WS.ServerApp
@ -844,7 +844,7 @@ dynamicCerts = do
Just "example.com" -> loadCredentials "example.pem" "example-key.pem" Just "example.com" -> loadCredentials "example.pem" "example-key.pem"
Just "other.com" -> loadCredentials "other.pem" "other-key.pem" Just "other.com" -> loadCredentials "other.pem" "other-key.pem"
_ -> loadCredentials "default.pem" "default-key.pem" _ -> loadCredentials "default.pem" "default-key.pem"
runTLS tlsOpts defaultSettings app runTLS tlsOpts defaultSettings app
loadCredentials :: FilePath -> FilePath -> IO Credentials loadCredentials :: FilePath -> FilePath -> IO Credentials
@ -909,7 +909,7 @@ gracefulShutdown = do
let settings = setInstallShutdownHandler shutdownHandler let settings = setInstallShutdownHandler shutdownHandler
$ setGracefulShutdownTimeout (Just 30) -- 30 seconds max $ setGracefulShutdownTimeout (Just 30) -- 30 seconds max
$ setPort 8080 defaultSettings $ setPort 8080 defaultSettings
runSettings settings app runSettings settings app
where where
shutdownHandler closeSocket = do shutdownHandler closeSocket = do
@ -935,7 +935,7 @@ gracefulShutdown = do
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
productionSettings :: Settings productionSettings :: Settings
productionSettings = productionSettings =
setPort 443 setPort 443
$ setHost "*" $ setHost "*"
$ setOnOpen onOpen $ setOnOpen onOpen
@ -953,13 +953,13 @@ productionSettings =
onOpen sockAddr = do onOpen sockAddr = do
putStrLn $ "Connection: " ++ show sockAddr putStrLn $ "Connection: " ++ show sockAddr
return True return True
onClose sockAddr = onClose sockAddr =
putStrLn $ "Closed: " ++ show sockAddr putStrLn $ "Closed: " ++ show sockAddr
onException _ e = onException _ e =
putStrLn $ "Exception: " ++ show e putStrLn $ "Exception: " ++ show e
shutdownHandler closeSocket = do shutdownHandler closeSocket = do
_ <- installHandler sigTERM (Catch closeSocket) Nothing _ <- installHandler sigTERM (Catch closeSocket) Nothing
_ <- installHandler sigINT (Catch closeSocket) Nothing _ <- installHandler sigINT (Catch closeSocket) Nothing
@ -1023,16 +1023,16 @@ websocketHandler pending = do
-- HTTP handler (including streaming) -- HTTP handler (including streaming)
httpHandler :: Application httpHandler :: Application
httpHandler req respond = httpHandler req respond =
case pathInfo req of case pathInfo req of
["stream"] -> respond $ streamingResponse ["stream"] -> respond $ streamingResponse
["ws"] -> respond $ responseLBS status404 [] "Use WebSocket protocol" ["ws"] -> respond $ responseLBS status404 [] "Use WebSocket protocol"
_ -> respond $ responseLBS status200 [] "Hello HTTP" _ -> respond $ responseLBS status200 [] "Hello HTTP"
streamingResponse :: Response streamingResponse :: Response
streamingResponse = responseStream streamingResponse = responseStream
status200 status200
[("Content-Type", "text/event-stream")] [("Content-Type", "text/event-stream")]
$ \write flush -> forever $ do $ \write flush -> forever $ do
threadDelay 1000000 threadDelay 1000000
write $ byteString "data: tick\n\n" write $ byteString "data: tick\n\n"
@ -1067,10 +1067,10 @@ server {
proxy_set_header Upgrade $http_upgrade; proxy_set_header Upgrade $http_upgrade;
proxy_set_header Connection $connection_upgrade; proxy_set_header Connection $connection_upgrade;
proxy_set_header Host $host; proxy_set_header Host $host;
# Critical: disable buffering # Critical: disable buffering
proxy_buffering off; proxy_buffering off;
# Increase timeouts # Increase timeouts
proxy_read_timeout 86400s; proxy_read_timeout 86400s;
proxy_send_timeout 86400s; proxy_send_timeout 86400s;
@ -1080,11 +1080,11 @@ server {
location /stream/ { location /stream/ {
proxy_pass http://localhost:8002; proxy_pass http://localhost:8002;
proxy_http_version 1.1; proxy_http_version 1.1;
# Critical: disable buffering for streaming # Critical: disable buffering for streaming
proxy_buffering off; proxy_buffering off;
proxy_cache off; proxy_cache off;
# Keep connection alive # Keep connection alive
proxy_set_header Connection ''; proxy_set_header Connection '';
proxy_set_header Cache-Control 'no-cache'; proxy_set_header Cache-Control 'no-cache';
@ -1242,9 +1242,9 @@ For unidirectional streaming, SSE offers advantages:
```haskell ```haskell
sseHandler :: Application sseHandler :: Application
sseHandler _req respond = respond $ sseHandler _req respond = respond $
responseStream status200 responseStream status200
[("Content-Type", "text/event-stream"), [("Content-Type", "text/event-stream"),
("Cache-Control", "no-cache")] ("Cache-Control", "no-cache")]
$ \write flush -> forever $ do $ \write flush -> forever $ do
threadDelay 1000000 threadDelay 1000000
write $ byteString "data: update\n\n" write $ byteString "data: update\n\n"

View File

@ -163,14 +163,14 @@ server {
listen 443 ssl; listen 443 ssl;
listen [::]:443 ssl; listen [::]:443 ssl;
http2 on; http2 on;
# HTTP/3 over UDP # HTTP/3 over UDP
listen 443 quic reuseport; listen 443 quic reuseport;
listen [::]:443 quic reuseport; listen [::]:443 quic reuseport;
ssl_protocols TLSv1.2 TLSv1.3; ssl_protocols TLSv1.2 TLSv1.3;
add_header Alt-Svc 'h3=":443"; ma=86400' always; add_header Alt-Svc 'h3=":443"; ma=86400' always;
location / { location / {
proxy_pass http://localhost:3000; # Warp proxy_pass http://localhost:3000; # Warp
proxy_http_version 1.1; proxy_http_version 1.1;
@ -221,7 +221,7 @@ import Control.Monad.Trans.Resource
app :: Application app :: Application
app req respond = runResourceT $ do app req respond = runResourceT $ do
(releaseKey, handle) <- allocate (releaseKey, handle) <- allocate
(openFile "data.txt" ReadMode) (openFile "data.txt" ReadMode)
hClose hClose
content <- liftIO $ hGetContents handle content <- liftIO $ hGetContents handle

View File

@ -88,7 +88,7 @@ data Backend = Backend
} }
trackConnection :: Backend -> IO a -> IO a trackConnection :: Backend -> IO a -> IO a
trackConnection backend action = trackConnection backend action =
bracket_ bracket_
(atomically $ modifyTVar' (activeConnections backend) (+1)) (atomically $ modifyTVar' (activeConnections backend) (+1))
(atomically $ modifyTVar' (activeConnections backend) (subtract 1)) (atomically $ modifyTVar' (activeConnections backend) (subtract 1))
@ -110,7 +110,7 @@ This pattern **composes naturally with health checks** - the STM transaction can
import Control.Concurrent.LoadDistribution import Control.Concurrent.LoadDistribution
lb <- evenlyDistributed (return $ Set.fromList backends) lb <- evenlyDistributed (return $ Set.fromList backends)
withResource lb $ \maybeBackend -> withResource lb $ \maybeBackend ->
case maybeBackend of case maybeBackend of
Just backend -> proxyRequest backend Just backend -> proxyRequest backend
Nothing -> handleNoBackends Nothing -> handleNoBackends
@ -132,18 +132,18 @@ data WeightedBackend a = WeightedBackend
smoothWeightedSelect :: [WeightedBackend a] -> IO a smoothWeightedSelect :: [WeightedBackend a] -> IO a
smoothWeightedSelect backends = atomically $ do smoothWeightedSelect backends = atomically $ do
-- Increase all current weights by their base weights -- Increase all current weights by their base weights
forM_ backends $ \wb -> forM_ backends $ \wb ->
modifyTVar' (currentWeight wb) (+ weight wb) modifyTVar' (currentWeight wb) (+ weight wb)
-- Find backend with maximum current weight -- Find backend with maximum current weight
weights <- mapM (readTVar . currentWeight) backends weights <- mapM (readTVar . currentWeight) backends
let maxWeight = maximum weights let maxWeight = maximum weights
selected = backends !! fromJust (findIndex (== maxWeight) weights) selected = backends !! fromJust (findIndex (== maxWeight) weights)
-- Reduce selected backend's current weight by total -- Reduce selected backend's current weight by total
let totalWeight = sum (map weight backends) let totalWeight = sum (map weight backends)
modifyTVar' (currentWeight selected) (subtract totalWeight) modifyTVar' (currentWeight selected) (subtract totalWeight)
return $ backend selected return $ backend selected
``` ```
@ -188,7 +188,7 @@ data BackendState = BackendState
-- BAD: Touches many TVars in single transaction -- BAD: Touches many TVars in single transaction
countAllConnections :: [Backend] -> STM Int countAllConnections :: [Backend] -> STM Int
countAllConnections backends = countAllConnections backends =
sum <$> mapM (readTVar . activeConns) backends sum <$> mapM (readTVar . activeConns) backends
-- GOOD: Maintain aggregate counter -- GOOD: Maintain aggregate counter
@ -281,7 +281,7 @@ The `retry` primitive is STM's killer feature - **threads automatically block un
badPattern = atomically $ do badPattern = atomically $ do
val <- expensiveComputation -- Recomputed on every retry! val <- expensiveComputation -- Recomputed on every retry!
tvar <- readTVar someTVar tvar <- readTVar someTVar
-- GOOD: Pure computation outside -- GOOD: Pure computation outside
goodPattern = do goodPattern = do
let val = expensiveComputation let val = expensiveComputation
@ -299,7 +299,7 @@ goodPattern = do
```haskell ```haskell
-- Update multiple backend states atomically -- Update multiple backend states atomically
updateHealthChecks :: [Backend] -> [(Backend, Bool)] -> STM () updateHealthChecks :: [Backend] -> [(Backend, Bool)] -> STM ()
updateHealthChecks backends results = updateHealthChecks backends results =
forM_ results $ \(backend, isHealthy) -> forM_ results $ \(backend, isHealthy) ->
writeTVar (healthy backend) isHealthy writeTVar (healthy backend) isHealthy
``` ```
@ -344,7 +344,7 @@ performHealthCheck manager config backend = do
req <- parseRequest url req <- parseRequest url
response <- httpLbs req manager response <- httpLbs req manager
return $ statusCode (responseStatus response) == 200 return $ statusCode (responseStatus response) == 200
return $ fromMaybe False result return $ fromMaybe False result
``` ```
@ -362,13 +362,13 @@ import Control.Monad (forever)
healthCheckLoop :: Manager -> HealthCheckConfig -> [Backend] -> IO () healthCheckLoop :: Manager -> HealthCheckConfig -> [Backend] -> IO ()
healthCheckLoop manager config backends = forever $ do healthCheckLoop manager config backends = forever $ do
-- Check all backends concurrently -- Check all backends concurrently
results <- mapConcurrently results <- mapConcurrently
(performHealthCheck manager config) (performHealthCheck manager config)
backends backends
-- Update backend states -- Update backend states
zipWithM_ (updateBackendState config) backends results zipWithM_ (updateBackendState config) backends results
-- Wait for next interval -- Wait for next interval
threadDelay (hcInterval config * 1000000) threadDelay (hcInterval config * 1000000)
@ -414,7 +414,7 @@ updateBackendState config backend healthy = atomically $ do
state <- readTVar (backendState backend) state <- readTVar (backendState backend)
failures <- readTVar (backendFailures backend) failures <- readTVar (backendFailures backend)
successes <- readTVar (backendSuccesses backend) successes <- readTVar (backendSuccesses backend)
case (state, healthy) of case (state, healthy) of
(Healthy, False) -> do (Healthy, False) -> do
let newFailures = failures + 1 let newFailures = failures + 1
@ -422,22 +422,22 @@ updateBackendState config backend healthy = atomically $ do
when (newFailures >= hcMaxFailures config) $ do when (newFailures >= hcMaxFailures config) $ do
writeTVar (backendState backend) Unhealthy writeTVar (backendState backend) Unhealthy
writeTVar (backendFailures backend) 0 writeTVar (backendFailures backend) 0
(Unhealthy, True) -> do (Unhealthy, True) -> do
writeTVar (backendState backend) Recovering writeTVar (backendState backend) Recovering
writeTVar (backendSuccesses backend) 1 writeTVar (backendSuccesses backend) 1
(Recovering, True) -> do (Recovering, True) -> do
let newSuccesses = successes + 1 let newSuccesses = successes + 1
writeTVar (backendSuccesses backend) newSuccesses writeTVar (backendSuccesses backend) newSuccesses
when (newSuccesses >= hcRecoveryAttempts config) $ do when (newSuccesses >= hcRecoveryAttempts config) $ do
writeTVar (backendState backend) Healthy writeTVar (backendState backend) Healthy
writeTVar (backendSuccesses backend) 0 writeTVar (backendSuccesses backend) 0
(Recovering, False) -> do (Recovering, False) -> do
writeTVar (backendState backend) Unhealthy writeTVar (backendState backend) Unhealthy
writeTVar (backendSuccesses backend) 0 writeTVar (backendSuccesses backend) 0
_ -> return () _ -> return ()
``` ```
@ -458,15 +458,15 @@ testBreaker = undefined
proxyWithCircuitBreaker :: Backend -> Request -> IO Response proxyWithCircuitBreaker :: Backend -> Request -> IO Response
proxyWithCircuitBreaker backend req = do proxyWithCircuitBreaker backend req = do
cbConf <- initialBreakerState cbConf <- initialBreakerState
result <- flip runReaderT cbConf $ result <- flip runReaderT cbConf $
withBreaker testBreaker $ liftIO $ forwardRequest backend req withBreaker testBreaker $ liftIO $ forwardRequest backend req
case result of case result of
Left (CircuitBreakerClosed msg) -> Left (CircuitBreakerClosed msg) ->
-- Circuit open, return cached response or error -- Circuit open, return cached response or error
return $ errorResponse 503 "Service Temporarily Unavailable" return $ errorResponse 503 "Service Temporarily Unavailable"
Right response -> Right response ->
return response return response
``` ```
@ -521,7 +521,7 @@ exponentialBackoffWithJitter config action = go 0 (initialDelay config)
```haskell ```haskell
import Control.Retry import Control.Retry
recovering recovering
(exponentialBackoff 50000 <> limitRetries 5) (exponentialBackoff 50000 <> limitRetries 5)
[const $ Handler $ \e -> return (isRetryable e)] [const $ Handler $ \e -> return (isRetryable e)]
(\_ -> performHealthCheck backend) (\_ -> performHealthCheck backend)
@ -554,16 +554,16 @@ proxyApp :: ProxyConfig -> Application
proxyApp config req respond = do proxyApp config req respond = do
mBackend <- selectHealthyBackend (pcBalancer config) mBackend <- selectHealthyBackend (pcBalancer config)
case mBackend of case mBackend of
Nothing -> Nothing ->
respond $ responseLBS status503 [] "No healthy backends available" respond $ responseLBS status503 [] "No healthy backends available"
Just backend -> Just backend ->
waiProxyTo waiProxyTo
(\_ -> return $ WPRProxyDest (ProxyDest (\_ -> return $ WPRProxyDest (ProxyDest
(backendHost backend) (backendHost backend)
(backendPort backend))) (backendPort backend)))
defaultOnExc defaultOnExc
(pcManager config) (pcManager config)
req req
respond respond
``` ```
@ -585,7 +585,7 @@ import Network.Wai (Middleware, mapResponseHeaders)
-- Add load balancer info header -- Add load balancer info header
addBackendHeader :: Backend -> Middleware addBackendHeader :: Backend -> Middleware
addBackendHeader backend app req respond = addBackendHeader backend app req respond =
app req $ respond . mapResponseHeaders app req $ respond . mapResponseHeaders
((hBackend, encodeUtf8 $ backendId backend) :) ((hBackend, encodeUtf8 $ backendId backend) :)
-- Connection tracking middleware -- Connection tracking middleware
@ -593,18 +593,18 @@ trackingMiddleware :: ServerMetrics -> Middleware
trackingMiddleware metrics app req respond = do trackingMiddleware metrics app req respond = do
atomically $ modifyTVar' (activeConnections metrics) (+1) atomically $ modifyTVar' (activeConnections metrics) (+1)
atomically $ modifyTVar' (totalRequests metrics) (+1) atomically $ modifyTVar' (totalRequests metrics) (+1)
let respond' res = do let respond' res = do
atomically $ modifyTVar' (activeConnections metrics) (subtract 1) atomically $ modifyTVar' (activeConnections metrics) (subtract 1)
respond res respond res
app req respond' `onException` app req respond' `onException`
atomically (modifyTVar' (errorCount metrics) (+1)) atomically (modifyTVar' (errorCount metrics) (+1))
-- Compose middleware -- Compose middleware
main = do main = do
config <- initProxyConfig config <- initProxyConfig
let app = trackingMiddleware metrics let app = trackingMiddleware metrics
$ proxyApp config $ proxyApp config
run 8000 app run 8000 app
``` ```
@ -624,7 +624,7 @@ main = do
**Compile-time optimizations**: **Compile-time optimizations**:
```cabal ```cabal
ghc-options: -Wall -O2 -threaded ghc-options: -Wall -O2 -threaded
-rtsopts -with-rtsopts=-N -rtsopts -with-rtsopts=-N
-fspec-constr -fspecialise -fspec-constr -fspecialise
-funbox-strict-fields -funbox-strict-fields
@ -709,7 +709,7 @@ data ProxyConfig = ProxyConfig
-- Backend selection dispatcher -- Backend selection dispatcher
selectBackend :: ProxyConfig -> IO (Maybe Backend) selectBackend :: ProxyConfig -> IO (Maybe Backend)
selectBackend config = selectBackend config =
case strategy config of case strategy config of
RoundRobin -> selectRoundRobin config RoundRobin -> selectRoundRobin config
LeastConnections -> selectLeastConnections config LeastConnections -> selectLeastConnections config
@ -722,7 +722,7 @@ selectRoundRobin config = do
len = V.length backends' len = V.length backends'
idx <- atomicModifyIORef' (rrCounter config) $ \i -> idx <- atomicModifyIORef' (rrCounter config) $ \i ->
((i + 1) `mod` len, i) ((i + 1) `mod` len, i)
-- Find next healthy backend -- Find next healthy backend
findHealthy backends' idx len findHealthy backends' idx len
where where
@ -733,7 +733,7 @@ selectRoundRobin config = do
isHealthy <- atomically $ (== Healthy) <$> readTVar (state backend) isHealthy <- atomically $ (== Healthy) <$> readTVar (state backend)
if isHealthy if isHealthy
then return (Just backend) then return (Just backend)
else findHealthy backends' else findHealthy backends'
((start + 1) `mod` V.length backends') ((start + 1) `mod` V.length backends')
(remaining - 1) (remaining - 1)
@ -756,24 +756,24 @@ selectLeastConnections config = do
selectWeightedRR :: ProxyConfig -> IO (Maybe Backend) selectWeightedRR :: ProxyConfig -> IO (Maybe Backend)
selectWeightedRR config = atomically $ do selectWeightedRR config = atomically $ do
let backends' = V.toList (backends config) let backends' = V.toList (backends config)
-- Increase current weights -- Increase current weights
forM_ backends' $ \wb -> forM_ backends' $ \wb ->
modifyTVar' (currentWeight wb) (+ backendWeight wb) modifyTVar' (currentWeight wb) (+ backendWeight wb)
-- Select backend with max current weight -- Select backend with max current weight
weights <- mapM (readTVar . currentWeight) backends' weights <- mapM (readTVar . currentWeight) backends'
let maxWeight = maximum weights let maxWeight = maximum weights
selected = backends' !! fromJust (findIndex (== maxWeight) weights) selected = backends' !! fromJust (findIndex (== maxWeight) weights)
-- Check health -- Check health
isHealthy <- (== Healthy) <$> readTVar (state selected) isHealthy <- (== Healthy) <$> readTVar (state selected)
guard isHealthy guard isHealthy
-- Reduce selected backend's current weight -- Reduce selected backend's current weight
let totalWeight = sum (map backendWeight backends') let totalWeight = sum (map backendWeight backends')
modifyTVar' (currentWeight selected) (subtract totalWeight) modifyTVar' (currentWeight selected) (subtract totalWeight)
return selected return selected
-- Main proxy application -- Main proxy application
@ -781,17 +781,17 @@ proxyApp :: ProxyConfig -> Application
proxyApp config req respond = do proxyApp config req respond = do
mBackend <- selectBackend config mBackend <- selectBackend config
case mBackend of case mBackend of
Nothing -> Nothing ->
respond $ responseLBS status503 [] "No healthy backends" respond $ responseLBS status503 [] "No healthy backends"
Just backend -> do Just backend -> do
-- Track connection -- Track connection
atomically $ modifyTVar' (activeConns backend) (+1) atomically $ modifyTVar' (activeConns backend) (+1)
let dest = ProxyDest (backendHost backend) (backendPort backend) let dest = ProxyDest (backendHost backend) (backendPort backend)
respond' res = do respond' res = do
atomically $ modifyTVar' (activeConns backend) (subtract 1) atomically $ modifyTVar' (activeConns backend) (subtract 1)
respond res respond res
waiProxyTo waiProxyTo
(\_ -> return $ WPRProxyDest dest) (\_ -> return $ WPRProxyDest dest)
defaultOnExc defaultOnExc
@ -807,14 +807,14 @@ healthCheckLoop manager backends = forever $ do
threadDelay 10000000 -- 10 seconds threadDelay 10000000 -- 10 seconds
where where
checkHealth mgr backend = do checkHealth mgr backend = do
let url = "http://" <> backendHost backend <> ":" let url = "http://" <> backendHost backend <> ":"
<> show (backendPort backend) <> "/health" <> show (backendPort backend) <> "/health"
result <- timeout 2000000 $ do result <- timeout 2000000 $ do
req <- parseRequest (unpack url) req <- parseRequest (unpack url)
response <- httpLbs req mgr response <- httpLbs req mgr
return $ statusCode (responseStatus response) == 200 return $ statusCode (responseStatus response) == 200
return $ fromMaybe False result return $ fromMaybe False result
updateHealth backend healthy = atomically $ do updateHealth backend healthy = atomically $ do
currentState <- readTVar (state backend) currentState <- readTVar (state backend)
failureCount <- readTVar (failures backend) failureCount <- readTVar (failures backend)
@ -838,7 +838,7 @@ initProxyConfig specs strat = do
manager <- newTlsManager manager <- newTlsManager
counter <- newIORef 0 counter <- newIORef 0
checker <- async $ healthCheckLoop manager (V.toList backends) checker <- async $ healthCheckLoop manager (V.toList backends)
return ProxyConfig return ProxyConfig
{ backends = backends { backends = backends
, strategy = strat , strategy = strat
@ -859,18 +859,18 @@ initProxyConfig specs strat = do
-- Main entry point -- Main entry point
main :: IO () main :: IO ()
main = do main = do
let backendSpecs = let backendSpecs =
[ BackendSpec "localhost" 8001 5 [ BackendSpec "localhost" 8001 5
, BackendSpec "localhost" 8002 1 , BackendSpec "localhost" 8002 1
, BackendSpec "localhost" 8003 1 , BackendSpec "localhost" 8003 1
] ]
config <- initProxyConfig backendSpecs SmoothWeightedRR config <- initProxyConfig backendSpecs SmoothWeightedRR
let settings = setPort 8000 let settings = setPort 8000
$ setTimeout 30 $ setTimeout 30
$ defaultSettings $ defaultSettings
putStrLn "Load balancing proxy started on port 8000" putStrLn "Load balancing proxy started on port 8000"
runSettings settings (proxyApp config) runSettings settings (proxyApp config)
``` ```
@ -939,8 +939,8 @@ import Test.DejaFu
testNoDeadlock :: IO () testNoDeadlock :: IO ()
testNoDeadlock = autocheck $ do testNoDeadlock = autocheck $ do
balancer <- setup balancer <- setup
concurrently_ concurrently_
(selectBackend balancer) (selectBackend balancer)
(selectBackend balancer) (selectBackend balancer)
``` ```

View File

@ -30,13 +30,13 @@ import Foreign.C.Types
import System.Posix.Types (Fd(..)) import System.Posix.Types (Fd(..))
foreign import ccall unsafe "splice" foreign import ccall unsafe "splice"
c_splice :: CInt -> Ptr CLong -> CInt -> Ptr CLong c_splice :: CInt -> Ptr CLong -> CInt -> Ptr CLong
-> CSize -> CUInt -> IO CSsize -> CSize -> CUInt -> IO CSsize
splice :: Fd -> Fd -> Int -> [SpliceFlag] -> IO Int splice :: Fd -> Fd -> Int -> [SpliceFlag] -> IO Int
splice (Fd fdIn) (Fd fdOut) len flags = do splice (Fd fdIn) (Fd fdOut) len flags = do
let cflags = foldr (.|.) 0 [f | SpliceFlag f <- flags] let cflags = foldr (.|.) 0 [f | SpliceFlag f <- flags]
result <- c_splice fdIn nullPtr fdOut nullPtr result <- c_splice fdIn nullPtr fdOut nullPtr
(fromIntegral len) cflags (fromIntegral len) cflags
if result == -1 if result == -1
then throwErrno "splice" then throwErrno "splice"
@ -59,10 +59,10 @@ The `simple-sendfile` package powers Warp's high-performance static file serving
```haskell ```haskell
import Network.Sendfile import Network.Sendfile
sendfileWithHeader :: Socket -> FilePath -> FileRange sendfileWithHeader :: Socket -> FilePath -> FileRange
-> IO () -> [ByteString] -> IO () -> IO () -> [ByteString] -> IO ()
-- Sends headers and file data efficiently -- Sends headers and file data efficiently
sendfileWithHeader sock path (PartOfFile offset len) sendfileWithHeader sock path (PartOfFile offset len)
tickle headers tickle headers
``` ```
@ -77,7 +77,7 @@ spliceWithRetry :: Fd -> Fd -> Int -> IO ()
spliceWithRetry fdIn fdOut chunkSize = loop spliceWithRetry fdIn fdOut chunkSize = loop
where where
loop = do loop = do
result <- try $ splice fdIn fdOut chunkSize result <- try $ splice fdIn fdOut chunkSize
[spliceNonBlock, spliceMore] [spliceNonBlock, spliceMore]
case result of case result of
Right 0 -> return () -- EOF Right 0 -> return () -- EOF
@ -111,15 +111,15 @@ Conversion costs between variants matter significantly. `toStrict` forces entire
```haskell ```haskell
import Data.ByteString.Builder import Data.ByteString.Builder
buildHttpResponse :: Int -> [(ByteString, ByteString)] buildHttpResponse :: Int -> [(ByteString, ByteString)]
-> LazyByteString -> LazyByteString -> LazyByteString -> LazyByteString
buildHttpResponse status headers body = toLazyByteString builder buildHttpResponse status headers body = toLazyByteString builder
where where
builder = statusLine <> headerLines builder = statusLine <> headerLines
<> byteString "\r\n" <> lazyByteString body <> byteString "\r\n" <> lazyByteString body
statusLine = byteString "HTTP/1.1 " <> intDec status statusLine = byteString "HTTP/1.1 " <> intDec status
<> byteString " OK\r\n" <> byteString " OK\r\n"
headerLines = mconcat headerLines = mconcat
[ byteString k <> byteString ": " <> byteString v <> byteString "\r\n" [ byteString k <> byteString ": " <> byteString v <> byteString "\r\n"
| (k, v) <- headers ] | (k, v) <- headers ]
``` ```
@ -134,7 +134,7 @@ import Data.Pool
createBackendPool :: HostName -> PortNumber -> IO (Pool Socket) createBackendPool :: HostName -> PortNumber -> IO (Pool Socket)
createBackendPool host port = do createBackendPool host port = do
capabilities <- getNumCapabilities capabilities <- getNumCapabilities
newPool $ newPool $
defaultPoolConfig defaultPoolConfig
(connectBackend host port) -- Create function (connectBackend host port) -- Create function
close -- Destroy function close -- Destroy function
@ -228,7 +228,7 @@ Interpreting results requires understanding latency distribution. The `--latency
``` ```
Latency Distribution Latency Distribution
50% 635.91us 50% 635.91us
75% 712.34us 75% 712.34us
90% 1.04ms 90% 1.04ms
99% 2.87ms 99% 2.87ms
``` ```
@ -385,7 +385,7 @@ ThreadScope displays CPU activity across cores, spark creation/conversion (for p
**Profiling workflow progresses systematically**: **Profiling workflow progresses systematically**:
1. **Baseline measurement** with `-O2 +RTS -s` establishes initial performance 1. **Baseline measurement** with `-O2 +RTS -s` establishes initial performance
2. **Time profiling** with `-prof -fprof-late +RTS -p` identifies CPU hotspots 2. **Time profiling** with `-prof -fprof-late +RTS -p` identifies CPU hotspots
3. **Memory profiling** with `-hd -l` and eventlog2html reveals allocation patterns 3. **Memory profiling** with `-hd -l` and eventlog2html reveals allocation patterns
4. **Detailed investigation** using info table profiling for exact source locations 4. **Detailed investigation** using info table profiling for exact source locations
5. **Iterative optimization** applying fixes and re-profiling to verify improvements 5. **Iterative optimization** applying fixes and re-profiling to verify improvements
@ -401,7 +401,7 @@ Successful optimization follows priority order: algorithms trump micro-optimizat
**Compilation optimization checklist**: **Compilation optimization checklist**:
- [ ] Use `-O` or `-O2` for production builds - [ ] Use `-O` or `-O2` for production builds
- [ ] Add `-fllvm` for numeric-intensive code after benchmarking - [ ] Add `-fllvm` for numeric-intensive code after benchmarking
- [ ] Enable `-threaded` for concurrent programs - [ ] Enable `-threaded` for concurrent programs
- [ ] Include `-rtsopts` to allow runtime tuning - [ ] Include `-rtsopts` to allow runtime tuning
- [ ] Set `-with-rtsopts=-N` for automatic parallelism - [ ] Set `-with-rtsopts=-N` for automatic parallelism
- [ ] Use `optimization: 2` in cabal.project, not `ghc-options` - [ ] Use `optimization: 2` in cabal.project, not `ghc-options`
@ -483,7 +483,7 @@ import System.IO
data ProxyConfig = ProxyConfig data ProxyConfig = ProxyConfig
{ listenPort :: PortNumber { listenPort :: PortNumber
, targetHost :: HostName , targetHost :: HostName
, targetPort :: PortNumber , targetPort :: PortNumber
, poolStripes :: Int , poolStripes :: Int
, poolPerStripe :: Int , poolPerStripe :: Int
@ -492,8 +492,8 @@ data ProxyConfig = ProxyConfig
-- Create backend connection pool -- Create backend connection pool
createBackendPool :: ProxyConfig -> IO (Pool Socket) createBackendPool :: ProxyConfig -> IO (Pool Socket)
createBackendPool config = createBackendPool config =
newPool $ newPool $
defaultPoolConfig defaultPoolConfig
(connectBackend (targetHost config) (targetPort config)) (connectBackend (targetHost config) (targetPort config))
close close
@ -503,7 +503,7 @@ createBackendPool config =
connectBackend :: HostName -> PortNumber -> IO Socket connectBackend :: HostName -> PortNumber -> IO Socket
connectBackend host port = do connectBackend host port = do
addr:_ <- getAddrInfo addr:_ <- getAddrInfo
(Just defaultHints { addrSocketType = Stream }) (Just defaultHints { addrSocketType = Stream })
(Just host) (Just $ show port) (Just host) (Just $ show port)
sock <- socket (addrFamily addr) Stream defaultProtocol sock <- socket (addrFamily addr) Stream defaultProtocol
@ -517,18 +517,18 @@ runProxy :: ProxyConfig -> IO ()
runProxy config = do runProxy config = do
pool <- createBackendPool config pool <- createBackendPool config
addr:_ <- getAddrInfo addr:_ <- getAddrInfo
(Just defaultHints (Just defaultHints
{ addrSocketType = Stream { addrSocketType = Stream
, addrFlags = [AI_PASSIVE] }) , addrFlags = [AI_PASSIVE] })
Nothing (Just $ show $ listenPort config) Nothing (Just $ show $ listenPort config)
sock <- socket (addrFamily addr) Stream defaultProtocol sock <- socket (addrFamily addr) Stream defaultProtocol
setSocketOption sock ReuseAddr 1 setSocketOption sock ReuseAddr 1
bind sock (addrAddress addr) bind sock (addrAddress addr)
listen sock 128 listen sock 128
putStrLn $ "Proxy listening on port " ++ show (listenPort config) putStrLn $ "Proxy listening on port " ++ show (listenPort config)
forever $ do forever $ do
(client, clientAddr) <- accept sock (client, clientAddr) <- accept sock
forkIO $ handleClient pool client forkIO $ handleClient pool client
@ -538,27 +538,27 @@ runProxy config = do
handleClient :: Pool Socket -> Socket -> IO () handleClient :: Pool Socket -> Socket -> IO ()
handleClient pool client = do handleClient pool client = do
done <- newEmptyMVar done <- newEmptyMVar
withResource pool $ \backend -> do withResource pool $ \backend -> do
-- Bidirectional zero-copy forwarding -- Bidirectional zero-copy forwarding
let chunkSize = 65536 -- 64KB chunks let chunkSize = 65536 -- 64KB chunks
forkIO $ do forkIO $ do
result <- try $ splice chunkSize (client, Nothing) result <- try $ splice chunkSize (client, Nothing)
(backend, Nothing) (backend, Nothing)
case result of case result of
Left (e :: SomeException) -> Left (e :: SomeException) ->
putStrLn $ "Client->Backend error: " ++ show e putStrLn $ "Client->Backend error: " ++ show e
Right _ -> return () Right _ -> return ()
putMVar done () putMVar done ()
result <- try $ splice chunkSize (backend, Nothing) result <- try $ splice chunkSize (backend, Nothing)
(client, Nothing) (client, Nothing)
case result of case result of
Left (e :: SomeException) -> Left (e :: SomeException) ->
putStrLn $ "Backend->Client error: " ++ show e putStrLn $ "Backend->Client error: " ++ show e
Right _ -> return () Right _ -> return ()
takeMVar done takeMVar done
main :: IO () main :: IO ()
@ -582,7 +582,7 @@ main = do
import Data.ByteString.Builder import Data.ByteString.Builder
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
buildHttpResponse :: Int -> [(ByteString, ByteString)] buildHttpResponse :: Int -> [(ByteString, ByteString)]
-> BL.ByteString -> BL.ByteString -> BL.ByteString -> BL.ByteString
buildHttpResponse status headers body = toLazyByteString $ buildHttpResponse status headers body = toLazyByteString $
mconcat mconcat
@ -591,7 +591,7 @@ buildHttpResponse status headers body = toLazyByteString $
, byteString " " , byteString " "
, statusText status , statusText status
, byteString "\r\n" , byteString "\r\n"
, mconcat [ byteString k <> byteString ": " , mconcat [ byteString k <> byteString ": "
<> byteString v <> byteString "\r\n" <> byteString v <> byteString "\r\n"
| (k, v) <- headers ] | (k, v) <- headers ]
, byteString "\r\n" , byteString "\r\n"
@ -599,7 +599,7 @@ buildHttpResponse status headers body = toLazyByteString $
] ]
where where
statusText 200 = byteString "OK" statusText 200 = byteString "OK"
statusText 404 = byteString "Not Found" statusText 404 = byteString "Not Found"
statusText 500 = byteString "Internal Server Error" statusText 500 = byteString "Internal Server Error"
statusText _ = byteString "Unknown" statusText _ = byteString "Unknown"
``` ```
@ -616,14 +616,14 @@ parseRequestLine :: ByteString -> Maybe (ByteString, ByteString, ByteString)
parseRequestLine bs = do parseRequestLine bs = do
let (method, rest1) = BS.break (== space) bs let (method, rest1) = BS.break (== space) bs
guard (not $ BS.null rest1) guard (not $ BS.null rest1)
let rest2 = BS.drop 1 rest1 let rest2 = BS.drop 1 rest1
(path, rest3) = BS.break (== space) rest2 (path, rest3) = BS.break (== space) rest2
guard (not $ BS.null rest3) guard (not $ BS.null rest3)
let rest4 = BS.drop 1 rest3 let rest4 = BS.drop 1 rest3
(version, _) = BS.break (== cr) rest4 (version, _) = BS.break (== cr) rest4
return (method, path, version) return (method, path, version)
where where
space = 32; cr = 13 space = 32; cr = 13
@ -635,11 +635,11 @@ parseHeaders = go . BC.lines
go [] = [] go [] = []
go (line:rest) go (line:rest)
| BS.null line = [] | BS.null line = []
| otherwise = | otherwise =
case BC.break (== ':') line of case BC.break (== ':') line of
(key, value) (key, value)
| BS.null value -> go rest | BS.null value -> go rest
| otherwise -> | otherwise ->
let val = BS.dropWhile (== 32) (BS.drop 1 value) let val = BS.dropWhile (== 32) (BS.drop 1 value)
in (key, val) : go rest in (key, val) : go rest
``` ```

View File

@ -210,16 +210,16 @@ RateLimit: "default";r=0;t=60
async function fetchWithRetry(url, maxRetries = 3) { async function fetchWithRetry(url, maxRetries = 3) {
for (let attempt = 0; attempt < maxRetries; attempt++) { for (let attempt = 0; attempt < maxRetries; attempt++) {
const res = await fetch(url); const res = await fetch(url);
if (res.status === 429) { if (res.status === 429) {
const retryAfter = res.headers.get('retry-after'); const retryAfter = res.headers.get('retry-after');
const delay = parseInt(retryAfter) * 1000 || (1000 * Math.pow(2, attempt)); const delay = parseInt(retryAfter) * 1000 || (1000 * Math.pow(2, attempt));
const jitter = delay * 0.2 * (Math.random() - 0.5); const jitter = delay * 0.2 * (Math.random() - 0.5);
await sleep(delay + jitter); await sleep(delay + jitter);
continue; continue;
} }
return res; return res;
} }
throw new Error('Max retries exceeded'); throw new Error('Max retries exceeded');

View File

@ -91,10 +91,10 @@ tlsClient hostname port = do
addr:_ <- getAddrInfo Nothing (Just hostname) (Just port) addr:_ <- getAddrInfo Nothing (Just hostname) (Just port)
sock <- socket (addrFamily addr) Stream defaultProtocol sock <- socket (addrFamily addr) Stream defaultProtocol
connect sock (addrAddress addr) connect sock (addrAddress addr)
-- Configure TLS parameters -- Configure TLS parameters
let params = (defaultParamsClient hostname "") let params = (defaultParamsClient hostname "")
{ clientSupported = def { clientSupported = def
{ supportedCiphers = ciphersuite_default { supportedCiphers = ciphersuite_default
, supportedVersions = [TLS13, TLS12] , supportedVersions = [TLS13, TLS12]
, supportedGroups = [X25519, P256] , supportedGroups = [X25519, P256]
@ -103,16 +103,16 @@ tlsClient hostname port = do
{ sharedCAStore = systemStore { sharedCAStore = systemStore
} }
} }
-- Perform handshake -- Perform handshake
ctx <- contextNew sock params ctx <- contextNew sock params
handshake ctx handshake ctx
-- Send HTTP request -- Send HTTP request
sendData ctx "GET / HTTP/1.1\r\nHost: example.com\r\n\r\n" sendData ctx "GET / HTTP/1.1\r\nHost: example.com\r\n\r\n"
response <- recvData ctx response <- recvData ctx
print response print response
-- Clean shutdown -- Clean shutdown
bye ctx bye ctx
close sock close sock
@ -131,8 +131,8 @@ import qualified Network.TLS as TLS
import Network.TLS.Extra.Cipher import Network.TLS.Extra.Cipher
app :: Application app :: Application
app _ respond = app _ respond =
respond $ responseLBS status200 respond $ responseLBS status200
[("Content-Type", "text/plain") [("Content-Type", "text/plain")
,("Strict-Transport-Security", "max-age=31536000; includeSubDomains")] ,("Strict-Transport-Security", "max-age=31536000; includeSubDomains")]
"Secure HTTPS Server" "Secure HTTPS Server"
@ -144,11 +144,11 @@ main = do
, tlsCiphers = ciphersuite_strong , tlsCiphers = ciphersuite_strong
, onInsecure = DenyInsecure "HTTPS required" , onInsecure = DenyInsecure "HTTPS required"
} }
warpConfig = defaultSettings warpConfig = defaultSettings
& setPort 443 & setPort 443
& setHost "0.0.0.0" & setHost "0.0.0.0"
putStrLn "HTTPS server on :443" putStrLn "HTTPS server on :443"
runTLS tlsConfig warpConfig app runTLS tlsConfig warpConfig app
``` ```
@ -169,14 +169,14 @@ validateCertificate certFile hostname = do
-- Load certificate chain -- Load certificate chain
certs <- readSignedObject certFile certs <- readSignedObject certFile
let chain = CertificateChain certs let chain = CertificateChain certs
-- Get system CA store -- Get system CA store
store <- getSystemCertificateStore store <- getSystemCertificateStore
-- Validate with default checks -- Validate with default checks
let cache = exceptionValidationCache [] let cache = exceptionValidationCache []
failures <- validateDefault store cache (hostname, ":443") chain failures <- validateDefault store cache (hostname, ":443") chain
case failures of case failures of
[] -> putStrLn "✓ Certificate valid" >> return True [] -> putStrLn "✓ Certificate valid" >> return True
errs -> do errs -> do
@ -206,10 +206,10 @@ initializeKeys :: CertConfig -> IO ()
initializeKeys cfg = do initializeKeys cfg = do
accountExists <- doesFileExist (accountKey cfg) accountExists <- doesFileExist (accountKey cfg)
domainExists <- doesFileExist (domainKey cfg) domainExists <- doesFileExist (domainKey cfg)
unless accountExists $ unless accountExists $
callCommand $ "openssl genrsa 4096 > " ++ accountKey cfg callCommand $ "openssl genrsa 4096 > " ++ accountKey cfg
unless domainExists $ unless domainExists $
callCommand $ "openssl genrsa 4096 > " ++ domainKey cfg callCommand $ "openssl genrsa 4096 > " ++ domainKey cfg
@ -337,7 +337,7 @@ import qualified Network.TLS as TLS
customTlsManager :: IO Manager customTlsManager :: IO Manager
customTlsManager = do customTlsManager = do
let tlsParams = (TLS.defaultParamsClient "example.com" "") let tlsParams = (TLS.defaultParamsClient "example.com" "")
{ TLS.clientSupported = def { TLS.clientSupported = def
{ TLS.supportedCiphers = ciphersuite_strong { TLS.supportedCiphers = ciphersuite_strong
, TLS.supportedVersions = [TLS.TLS13, TLS.TLS12] , TLS.supportedVersions = [TLS.TLS13, TLS.TLS12]
} }
@ -346,15 +346,15 @@ customTlsManager = do
} }
} }
tlsSettings = TLSSettings tlsParams tlsSettings = TLSSettings tlsParams
newManager $ mkManagerSettings tlsSettings Nothing newManager $ mkManagerSettings tlsSettings Nothing
customValidation :: CertificateStore -> ValidationCache -> ServiceID customValidation :: CertificateStore -> ValidationCache -> ServiceID
-> CertificateChain -> IO [FailedReason] -> CertificateChain -> IO [FailedReason]
customValidation store cache sid chain = do customValidation store cache sid chain = do
-- Perform standard validation -- Perform standard validation
failures <- validateDefault store cache sid chain failures <- validateDefault store cache sid chain
-- Add custom checks (certificate pinning, etc.) -- Add custom checks (certificate pinning, etc.)
if null failures if null failures
then return [] then return []
@ -375,11 +375,11 @@ loadCredentials hostname = do
main :: IO () main :: IO ()
main = do main = do
let tlsConfig = tlsSettingsSni let tlsConfig = tlsSettingsSni
(return $ Just loadCredentials) (return $ Just loadCredentials)
"default.crt" "default.crt"
"default.key" "default.key"
runTLS tlsConfig defaultSettings app runTLS tlsConfig defaultSettings app
``` ```
@ -392,15 +392,15 @@ import Data.IORef
setupSessionManager :: IO SessionManager setupSessionManager :: IO SessionManager
setupSessionManager = do setupSessionManager = do
sessions <- newIORef Map.empty sessions <- newIORef Map.empty
return SessionManager return SessionManager
{ sessionResume = \sessionID -> do { sessionResume = \sessionID -> do
cache <- readIORef sessions cache <- readIORef sessions
return $ Map.lookup sessionID cache return $ Map.lookup sessionID cache
, sessionEstablish = \sessionID sessionData -> do , sessionEstablish = \sessionID sessionData -> do
modifyIORef' sessions (Map.insert sessionID sessionData) modifyIORef' sessions (Map.insert sessionID sessionData)
, sessionInvalidate = \sessionID -> do , sessionInvalidate = \sessionID -> do
modifyIORef' sessions (Map.delete sessionID) modifyIORef' sessions (Map.delete sessionID)
} }
@ -408,7 +408,7 @@ setupSessionManager = do
clientWithResumption :: HostName -> IO () clientWithResumption :: HostName -> IO ()
clientWithResumption hostname = do clientWithResumption hostname = do
manager <- setupSessionManager manager <- setupSessionManager
let params = (defaultParamsClient hostname "") let params = (defaultParamsClient hostname "")
{ clientShared = def { clientShared = def
{ sharedSessionManager = manager { sharedSessionManager = manager

View File

@ -68,14 +68,14 @@ Dhall represents a paradigm shift—a non-Turing-complete functional language sp
```dhall ```dhall
-- types.dhall -- types.dhall
let DatabaseConfig = let DatabaseConfig =
{ Type = { Type =
{ host : Text { host : Text
, port : Natural , port : Natural
, maxConnections : Natural , maxConnections : Natural
, replica : Optional DatabaseConfig.Type , replica : Optional DatabaseConfig.Type
} }
, default = , default =
{ host = "localhost" { host = "localhost"
, port = 5432 , port = 5432
, maxConnections = 20 , maxConnections = 20
@ -87,7 +87,7 @@ let DatabaseConfig =
let DB = ./types.dhall let DB = ./types.dhall
let staging = ./staging.dhall let staging = ./staging.dhall
in DB::{ in DB::{
, host = "prod-db.internal" , host = "prod-db.internal"
, port = 5432 , port = 5432
, maxConnections = 100 , maxConnections = 100
@ -133,11 +133,11 @@ data ServiceConfig = ServiceConfig
-- Type-safe DSL in Haskell -- Type-safe DSL in Haskell
myService :: ServiceConfig myService :: ServiceConfig
myService = ServiceConfig myService = ServiceConfig
{ routes = { routes =
[ route "/api" GET apiHandler [ route "/api" GET apiHandler
, route "/health" GET healthCheck , route "/health" GET healthCheck
] ]
, middleware = , middleware =
[ cors allowAll [ cors allowAll
, logging Verbose , logging Verbose
, auth jwtValidator , auth jwtValidator
@ -205,7 +205,7 @@ let identity : ∀(a : Type) → a → a =
λ(a : Type) → λ(x : a) → x λ(a : Type) → λ(x : a) → x
-- Type-safe record construction -- Type-safe record construction
let Config : Type = let Config : Type =
{ apiKey : Text { apiKey : Text
, endpoints : List { url : Text, port : Natural } , endpoints : List { url : Text, port : Natural }
, retries : Optional Natural , retries : Optional Natural
@ -270,7 +270,7 @@ watchConfigFile = withManager $ \mgr -> do
"." "."
(\event -> "config.yaml" `isSuffixOf` eventPath event) (\event -> "config.yaml" `isSuffixOf` eventPath event)
handleConfigChange handleConfigChange
forever $ threadDelay 1000000 forever $ threadDelay 1000000
handleConfigChange :: Event -> IO () handleConfigChange :: Event -> IO ()
@ -370,7 +370,7 @@ updateConfigs :: TVar AppConfig -> TVar CacheConfig -> IO ()
updateConfigs appVar cacheVar = atomically $ do updateConfigs appVar cacheVar = atomically $ do
app <- readTVar appVar app <- readTVar appVar
cache <- readTVar cacheVar cache <- readTVar cacheVar
-- Both updates happen atomically or retry -- Both updates happen atomically or retry
writeTVar appVar (app { maxConnections = 100 }) writeTVar appVar (app { maxConnections = 100 })
writeTVar cacheVar (cache { ttl = 3600 }) writeTVar cacheVar (cache { ttl = 3600 })
@ -418,16 +418,16 @@ initConfigManager path = do
Right config -> do Right config -> do
currentRef <- newIORef config currentRef <- newIORef config
lastValidRef <- newIORef config lastValidRef <- newIORef config
mgr <- startManager mgr <- startManager
let manager = ConfigManager currentRef lastValidRef path mgr let manager = ConfigManager currentRef lastValidRef path mgr
-- Start watching -- Start watching
_ <- watchDir mgr (takeDirectory path) _ <- watchDir mgr (takeDirectory path)
(matchesFile path) (matchesFile path)
(handleReload manager) (handleReload manager)
return $ Right manager return $ Right manager
where where
matchesFile target event = target == eventPath event matchesFile target event = target == eventPath event
@ -444,27 +444,27 @@ handleReload manager event = do
-- Save current as last valid -- Save current as last valid
current <- readIORef (currentConfig manager) current <- readIORef (currentConfig manager)
writeIORef (lastValidConfig manager) current writeIORef (lastValidConfig manager) current
-- Atomic swap to new config -- Atomic swap to new config
atomicWriteIORef (currentConfig manager) newConfig atomicWriteIORef (currentConfig manager) newConfig
logInfo "Config reloaded successfully" logInfo "Config reloaded successfully"
else else
logError "Validation failed, keeping old config" logError "Validation failed, keeping old config"
Left err -> do Left err -> do
logError $ "Reload failed: " ++ err logError $ "Reload failed: " ++ err
-- Keep running with old config -- Keep running with old config
where where
tryReload :: FilePath -> IO (Either String AppConfig) tryReload :: FilePath -> IO (Either String AppConfig)
tryReload path = tryReload path =
catch (eitherDecodeFileStrict path) catch (eitherDecodeFileStrict path)
(\(e :: SomeException) -> return $ Left $ show e) (\(e :: SomeException) -> return $ Left $ show e)
validateConfig :: AppConfig -> Bool validateConfig :: AppConfig -> Bool
validateConfig cfg = validateConfig cfg =
-- Custom validation logic -- Custom validation logic
not (null $ apiKeys cfg) not (null $ apiKeys cfg)
&& all isValidEndpoint (databaseEndpoints $ database cfg) && all isValidEndpoint (databaseEndpoints $ database cfg)
-- Access config safely from multiple threads -- Access config safely from multiple threads
@ -484,7 +484,7 @@ debounceReload :: IORef UTCTime -> NominalDiffTime -> IO () -> IO ()
debounceReload lastReloadRef minInterval action = do debounceReload lastReloadRef minInterval action = do
now <- getCurrentTime now <- getCurrentTime
lastReload <- readIORef lastReloadRef lastReload <- readIORef lastReloadRef
when (diffUTCTime now lastReload > minInterval) $ do when (diffUTCTime now lastReload > minInterval) $ do
writeIORef lastReloadRef now writeIORef lastReloadRef now
action action
@ -502,7 +502,7 @@ data DatabasePool = DatabasePool
rotatePoolCredentials :: DatabasePool -> Credentials -> IO () rotatePoolCredentials :: DatabasePool -> Credentials -> IO ()
rotatePoolCredentials dbPool newCreds = do rotatePoolCredentials dbPool newCreds = do
atomicWriteIORef (credentials dbPool) newCreds atomicWriteIORef (credentials dbPool) newCreds
-- Drain old connections gradually -- Drain old connections gradually
-- New connections use new credentials from IORef -- New connections use new credentials from IORef
drainPool (pool dbPool) gracefulDrainSeconds drainPool (pool dbPool) gracefulDrainSeconds
@ -556,7 +556,7 @@ loadConfigFailFast path = do
```haskell ```haskell
import Data.Validation import Data.Validation
data ValidationError = data ValidationError =
InvalidPort Int InvalidPort Int
| MissingField Text | MissingField Text
| InvalidFormat Text Text | InvalidFormat Text Text
@ -571,7 +571,7 @@ validateConfig raw = Config
validatePort p validatePort p
| p > 0 && p < 65536 = Success p | p > 0 && p < 65536 = Success p
| otherwise = Failure [InvalidPort p] | otherwise = Failure [InvalidPort p]
validateHost h validateHost h
| not (T.null h) = Success h | not (T.null h) = Success h
| otherwise = Failure [MissingField "host"] | otherwise = Failure [MissingField "host"]
@ -595,23 +595,23 @@ loadConfigGraceful path = do
Left err -> do Left err -> do
logWarning $ "Config parse error, using defaults: " ++ err logWarning $ "Config parse error, using defaults: " ++ err
return defaultConfig return defaultConfig
Right rawConfig -> do Right rawConfig -> do
-- Core settings must be valid -- Core settings must be valid
core <- case validateCore rawConfig of core <- case validateCore rawConfig of
Left errors -> error $ "Core config invalid: " ++ show errors Left errors -> error $ "Core config invalid: " ++ show errors
Right validated -> return validated Right validated -> return validated
-- Optional features use defaults on error -- Optional features use defaults on error
features <- case validateFeatures rawConfig of features <- case validateFeatures rawConfig of
Left errors -> do Left errors -> do
logWarning $ "Feature config invalid, using defaults: " ++ show errors logWarning $ "Feature config invalid, using defaults: " ++ show errors
return defaultFeatures return defaultFeatures
Right validated -> return validated Right validated -> return validated
-- Experimental flags filter out invalid entries -- Experimental flags filter out invalid entries
let flags = filterValidFlags (rawExperimental rawConfig) let flags = filterValidFlags (rawExperimental rawConfig)
return $ ConfigWithDefaults core features flags return $ ConfigWithDefaults core features flags
``` ```
@ -656,15 +656,15 @@ instance FromJSON ServerConfig where
rawPort <- o .: "port" rawPort <- o .: "port"
when (rawPort < 1 || rawPort > 65535) $ when (rawPort < 1 || rawPort > 65535) $
fail $ "Invalid port: " ++ show rawPort fail $ "Invalid port: " ++ show rawPort
host <- o .: "host" host <- o .: "host"
when (T.null host) $ when (T.null host) $
fail "Host cannot be empty" fail "Host cannot be empty"
workers <- o .:? "workers" .!= 4 -- Default to 4 workers <- o .:? "workers" .!= 4 -- Default to 4
when (workers < 1 || workers > 1000) $ when (workers < 1 || workers > 1000) $
fail $ "Invalid worker count: " ++ show workers fail $ "Invalid worker count: " ++ show workers
return $ ServerConfig rawPort host workers return $ ServerConfig rawPort host workers
``` ```
@ -729,9 +729,9 @@ interpolateEnvVars template = do
let varName = T.drop 2 $ T.dropEnd 1 match -- Strip ${ } let varName = T.drop 2 $ T.dropEnd 1 match -- Strip ${ }
maybeValue <- lookupEnv (T.unpack varName) maybeValue <- lookupEnv (T.unpack varName)
case maybeValue of case maybeValue of
Just value -> Just value ->
return $ Right $ T.replace match (T.pack value) txt return $ Right $ T.replace match (T.pack value) txt
Nothing -> Nothing ->
return $ Left $ "Undefined variable: " ++ T.unpack varName return $ Left $ "Undefined variable: " ++ T.unpack varName
-- With defaults -- With defaults
@ -755,7 +755,7 @@ import System.Envy
data AppConfig = AppConfig data AppConfig = AppConfig
{ appDatabaseUrl :: String -- DATABASE_URL { appDatabaseUrl :: String -- DATABASE_URL
, appRedisHost :: String -- REDIS_HOST , appRedisHost :: String -- REDIS_HOST
, appPort :: Int -- PORT , appPort :: Int -- PORT
, appDebug :: Bool -- DEBUG , appDebug :: Bool -- DEBUG
, appLogLevel :: Maybe LogLevel -- LOG_LEVEL (optional) , appLogLevel :: Maybe LogLevel -- LOG_LEVEL (optional)
@ -787,9 +787,9 @@ main = do
import Options.Applicative import Options.Applicative
import qualified Data.Yaml as Y import qualified Data.Yaml as Y
data ConfigSource = data ConfigSource =
CLIConfig Config CLIConfig Config
| EnvConfig Config | EnvConfig Config
| FileConfig Config | FileConfig Config
| DefaultConfig Config | DefaultConfig Config
@ -804,7 +804,7 @@ mergeConfigs sources = foldl merge defaultConfig sources
merge base (EnvConfig env) = base { port = port env `orDefault` port base } merge base (EnvConfig env) = base { port = port env `orDefault` port base }
merge base (FileConfig file) = base { port = port file `orDefault` port base } merge base (FileConfig file) = base { port = port file `orDefault` port base }
merge base (DefaultConfig _) = base merge base (DefaultConfig _) = base
orDefault :: Maybe a -> a -> a orDefault :: Maybe a -> a -> a
orDefault = fromMaybe orDefault = fromMaybe
@ -813,29 +813,29 @@ loadLayeredConfig :: IO Config
loadLayeredConfig = do loadLayeredConfig = do
-- 1. Load defaults -- 1. Load defaults
let defaults = defaultConfig let defaults = defaultConfig
-- 2. Load system config -- 2. Load system config
systemCfg <- loadSystemConfig `catch` \(_ :: IOException) -> return Nothing systemCfg <- loadSystemConfig `catch` \(_ :: IOException) -> return Nothing
-- 3. Load project config -- 3. Load project config
projectCfg <- loadProjectConfig `catch` \(_ :: IOException) -> return Nothing projectCfg <- loadProjectConfig `catch` \(_ :: IOException) -> return Nothing
-- 4. Load local config -- 4. Load local config
localCfg <- Y.decodeFileEither "config.yaml" >>= \case localCfg <- Y.decodeFileEither "config.yaml" >>= \case
Left _ -> return Nothing Left _ -> return Nothing
Right cfg -> return $ Just cfg Right cfg -> return $ Just cfg
-- 5. Load environment variables -- 5. Load environment variables
envCfg <- decodeEnv :: IO (Either String EnvConfig) envCfg <- decodeEnv :: IO (Either String EnvConfig)
let env = either (const Nothing) Just envCfg let env = either (const Nothing) Just envCfg
-- 6. Parse CLI args -- 6. Parse CLI args
cliCfg <- execParser cliParser cliCfg <- execParser cliParser
-- Merge with precedence -- Merge with precedence
return $ mergeConfigs return $ mergeConfigs
[ maybe DefaultConfig FileConfig systemCfg [ maybe DefaultConfig FileConfig systemCfg
, maybe DefaultConfig FileConfig projectCfg , maybe DefaultConfig FileConfig projectCfg
, maybe DefaultConfig FileConfig localCfg , maybe DefaultConfig FileConfig localCfg
, maybe DefaultConfig EnvConfig env , maybe DefaultConfig EnvConfig env
, CLIConfig cliCfg , CLIConfig cliCfg
@ -852,7 +852,7 @@ newtype SafeEnvValue = SafeEnvValue Text
validateEnvValue :: Text -> Either String SafeEnvValue validateEnvValue :: Text -> Either String SafeEnvValue
validateEnvValue value validateEnvValue value
| T.any isControlChar value = Left "Control characters not allowed" | T.any isControlChar value = Left "Control characters not allowed"
| T.any (== ';') value = Left "Semicolons not allowed" | T.any (== ';') value = Left "Semicolons not allowed"
| T.any (== '|') value = Left "Pipes not allowed" | T.any (== '|') value = Left "Pipes not allowed"
| otherwise = Right $ SafeEnvValue value | otherwise = Right $ SafeEnvValue value
where where
@ -903,10 +903,10 @@ loadSecrets :: VaultConnection -> IO (Either String AppSecrets)
loadSecrets conn = do loadSecrets conn = do
-- Get database credentials -- Get database credentials
dbResult <- getSecret conn (SecretPath "myapp/database") Nothing dbResult <- getSecret conn (SecretPath "myapp/database") Nothing
-- Get API keys -- Get API keys
apiResult <- getSecret conn (SecretPath "myapp/api-keys") Nothing apiResult <- getSecret conn (SecretPath "myapp/api-keys") Nothing
case (dbResult, apiResult) of case (dbResult, apiResult) of
(Right dbData, Right apiData) -> do (Right dbData, Right apiData) -> do
let dbCreds = parseCredentials $ fromSecretData dbData let dbCreds = parseCredentials $ fromSecretData dbData
@ -923,7 +923,7 @@ updateSecret conn = do
NoCheckAndSet NoCheckAndSet
(SecretPath "myapp/database") (SecretPath "myapp/database")
(toSecretData [("password", newPassword), ("username", "admin")]) (toSecretData [("password", newPassword), ("username", "admin")])
case result of case result of
Right version -> putStrLn $ "Updated to version " ++ show version Right version -> putStrLn $ "Updated to version " ++ show version
Left err -> putStrLn $ "Update failed: " ++ err Left err -> putStrLn $ "Update failed: " ++ err
@ -966,14 +966,14 @@ loadDatabaseConfig :: IO (Either String DatabaseConfig)
loadDatabaseConfig = do loadDatabaseConfig = do
-- Discover credentials (IAM role, env vars, etc.) -- Discover credentials (IAM role, env vars, etc.)
env <- newEnv discover env <- newEnv discover
-- Request secret -- Request secret
let req = newGetSecretValue "production/database" let req = newGetSecretValue "production/database"
resp <- runResourceT $ send env req resp <- runResourceT $ send env req
-- Extract and parse -- Extract and parse
case resp ^. getSecretValueResponse_secretString of case resp ^. getSecretValueResponse_secretString of
Just jsonString -> Just jsonString ->
case A.eitherDecode (encodeUtf8 jsonString) of case A.eitherDecode (encodeUtf8 jsonString) of
Right config -> return $ Right config Right config -> return $ Right config
Left err -> return $ Left $ "Parse error: " ++ err Left err -> return $ Left $ "Parse error: " ++ err
@ -983,13 +983,13 @@ loadDatabaseConfig = do
rotateSecret :: Text -> IO () rotateSecret :: Text -> IO ()
rotateSecret secretId = do rotateSecret secretId = do
env <- newEnv discover env <- newEnv discover
let req = newRotateSecret secretId let req = newRotateSecret secretId
& rotateSecret_rotationLambdaARN ?~ lambdaArn & rotateSecret_rotationLambdaARN ?~ lambdaArn
& rotateSecret_rotationRules ?~ & rotateSecret_rotationRules ?~
newRotationRulesType newRotationRulesType
& rotationRulesType_automaticallyAfterDays ?~ 30 & rotationRulesType_automaticallyAfterDays ?~ 30
_ <- runResourceT $ send env req _ <- runResourceT $ send env req
putStrLn "Rotation initiated" putStrLn "Rotation initiated"
``` ```
@ -1038,7 +1038,7 @@ withRotatingCreds rc action = do
Just prev -> action prev -- Fallback during rotation window Just prev -> action prev -- Fallback during rotation window
Nothing -> throwIO RotationError Nothing -> throwIO RotationError
where where
tryAction creds = tryAction creds =
catch (Right <$> action creds) catch (Right <$> action creds)
(\(e :: SomeException) -> return $ Left e) (\(e :: SomeException) -> return $ Left e)
@ -1047,22 +1047,22 @@ rotationLoop :: IORef RotatingCredentials -> VaultConnection -> IO ()
rotationLoop credsRef vault = forever $ do rotationLoop credsRef vault = forever $ do
currentTime <- getCurrentTime currentTime <- getCurrentTime
creds <- readIORef credsRef creds <- readIORef credsRef
when (shouldRotate currentTime (rotationTime creds)) $ do when (shouldRotate currentTime (rotationTime creds)) $ do
-- Fetch new credentials -- Fetch new credentials
newCreds <- fetchDynamicCreds vault newCreds <- fetchDynamicCreds vault
-- Update with both old and new -- Update with both old and new
atomicModifyIORef' credsRef $ \old -> atomicModifyIORef' credsRef $ \old ->
(RotatingCredentials newCreds (Just $ currentCreds old) currentTime, ()) (RotatingCredentials newCreds (Just $ currentCreds old) currentTime, ())
threadDelay (5 * 60 * 1000000) -- Check every 5 minutes threadDelay (5 * 60 * 1000000) -- Check every 5 minutes
-- Vault dynamic secrets with lease renewal -- Vault dynamic secrets with lease renewal
requestDynamicCredentials :: VaultConnection -> IO DynamicDBCredentials requestDynamicCredentials :: VaultConnection -> IO DynamicDBCredentials
requestDynamicCredentials conn = do requestDynamicCredentials conn = do
result <- vaultRead conn (VaultSecretPath "database/creds/readonly") result <- vaultRead conn (VaultSecretPath "database/creds/readonly")
case result of case result of
(metadata, Right creds) -> do (metadata, Right creds) -> do
-- Schedule renewal before expiration -- Schedule renewal before expiration
@ -1074,7 +1074,7 @@ renewLeaseLoop :: VaultConnection -> Text -> Int -> IO ()
renewLeaseLoop conn leaseId duration = do renewLeaseLoop conn leaseId duration = do
let renewInterval = duration `div` 2 -- Renew at halfway point let renewInterval = duration `div` 2 -- Renew at halfway point
threadDelay (renewInterval * 1000000) threadDelay (renewInterval * 1000000)
success <- renewLease conn leaseId success <- renewLease conn leaseId
if success if success
then renewLeaseLoop conn leaseId duration -- Continue renewing then renewLeaseLoop conn leaseId duration -- Continue renewing
@ -1086,7 +1086,7 @@ renewLeaseLoop conn leaseId duration = do
```haskell ```haskell
-- Never store secrets in code or config files -- Never store secrets in code or config files
-- ❌ DON'T DO THIS -- ❌ DON'T DO THIS
apiKey = "sk_live_abc123xyz" apiKey = "sk_live_abc123xyz"
-- ✅ Load from secure source -- ✅ Load from secure source
loadSecrets :: IO Secrets loadSecrets :: IO Secrets
@ -1222,12 +1222,12 @@ databaseCodec = DatabaseConfig
```dhall ```dhall
-- types/Database.dhall -- types/Database.dhall
let PoolConfig = { Type = let PoolConfig = { Type =
{ minConnections : Natural { minConnections : Natural
, maxConnections : Natural , maxConnections : Natural
, idleTimeout : Natural , idleTimeout : Natural
} }
, default = , default =
{ minConnections = 5 { minConnections = 5
, maxConnections = 20 , maxConnections = 20
, idleTimeout = 30 , idleTimeout = 30
@ -1259,11 +1259,11 @@ in DatabaseConfig
-- config/production.dhall -- config/production.dhall
let DB = ../types/Database.dhall let DB = ../types/Database.dhall
in DB::{ in DB::{
, host = "prod-db.internal" , host = "prod-db.internal"
, name = "production_db" , name = "production_db"
, pool = DB.default.pool // { maxConnections = 100 } , pool = DB.default.pool // { maxConnections = 100 }
, replicas = , replicas =
[ { host = "replica1.internal", port = 5432 } [ { host = "replica1.internal", port = 5432 }
, { host = "replica2.internal", port = 5432 } , { host = "replica2.internal", port = 5432 }
] ]
@ -1295,12 +1295,12 @@ initFeatureFlags :: FilePath -> IO FeatureFlagManager
initFeatureFlags path = do initFeatureFlags path = do
initial <- loadFeatureFlags path initial <- loadFeatureFlags path
flagsRef <- newIORef initial flagsRef <- newIORef initial
let manager = FeatureFlagManager flagsRef path let manager = FeatureFlagManager flagsRef path
-- Watch for changes -- Watch for changes
_ <- forkIO $ watchAndReload manager _ <- forkIO $ watchAndReload manager
return manager return manager
where where
loadFeatureFlags :: FilePath -> IO FeatureFlags loadFeatureFlags :: FilePath -> IO FeatureFlags
@ -1359,25 +1359,25 @@ loadConfig = do
Just "production" -> Production Just "production" -> Production
Just "staging" -> Staging Just "staging" -> Staging
_ -> Development _ -> Development
-- Load shared config -- Load shared config
shared <- decodeFileThrow "config/shared.yaml" shared <- decodeFileThrow "config/shared.yaml"
-- Load environment-specific config -- Load environment-specific config
let envFile = case env of let envFile = case env of
Development -> "config/development.yaml" Development -> "config/development.yaml"
Staging -> "config/staging.yaml" Staging -> "config/staging.yaml"
Production -> "config/production.yaml" Production -> "config/production.yaml"
envSpecific <- decodeFileThrow envFile envSpecific <- decodeFileThrow envFile
-- Merge with env vars (highest precedence) -- Merge with env vars (highest precedence)
envOverrides <- decodeEnv :: IO (Either String EnvOverrides) envOverrides <- decodeEnv :: IO (Either String EnvOverrides)
let finalConfig = case envOverrides of let finalConfig = case envOverrides of
Right overrides -> applyOverrides envSpecific overrides Right overrides -> applyOverrides envSpecific overrides
Left _ -> envSpecific Left _ -> envSpecific
return $ MultiEnvConfig shared env finalConfig return $ MultiEnvConfig shared env finalConfig
``` ```
@ -1424,7 +1424,7 @@ handleReload event = do
result <- try $ decodeFile path result <- try $ decodeFile path
case result of case result of
Right newConfig -> atomicWriteIORef configRef newConfig Right newConfig -> atomicWriteIORef configRef newConfig
Left (err :: SomeException) -> Left (err :: SomeException) ->
logError $ "Reload failed, keeping old config: " ++ show err logError $ "Reload failed, keeping old config: " ++ show err
``` ```
@ -1496,7 +1496,7 @@ let baseService = ./types/Service.dhall
let makeServiceConfig = λ(name : Text) → λ(port : Natural) → let makeServiceConfig = λ(name : Text) → λ(port : Natural) →
baseService::{ name = name, port = port } baseService::{ name = name, port = port }
in { services = in { services =
[ makeServiceConfig "api" 8080 [ makeServiceConfig "api" 8080
, makeServiceConfig "auth" 8081 , makeServiceConfig "auth" 8081
-- ... 48 more services with consistent structure -- ... 48 more services with consistent structure

View File

@ -189,16 +189,16 @@ Nginx's event-based architecture provides inherent resistance to connection exha
http { http {
# Time to read client request header # Time to read client request header
client_header_timeout 10s; client_header_timeout 10s;
# Time between successive body data reads # Time between successive body data reads
client_body_timeout 10s; client_body_timeout 10s;
# Keep-alive connection timeout # Keep-alive connection timeout
keepalive_timeout 15s; keepalive_timeout 15s;
# Time between successive writes to client # Time between successive writes to client
send_timeout 10s; send_timeout 10s;
# Buffer limits prevent memory exhaustion # Buffer limits prevent memory exhaustion
client_body_buffer_size 128k; client_body_buffer_size 128k;
client_header_buffer_size 2k; client_header_buffer_size 2k;
@ -228,19 +228,19 @@ LoadModule qos_module modules/mod_qos.so
<IfModule mod_qos.c> <IfModule mod_qos.c>
# Track 500,000 unique client IPs (150 bytes per entry) # Track 500,000 unique client IPs (150 bytes per entry)
QS_ClientEntries 500000 QS_ClientEntries 500000
# Maximum 20 concurrent connections per IP # Maximum 20 concurrent connections per IP
QS_SrvMaxConnPerIP 20 QS_SrvMaxConnPerIP 20
# Maximum 512 total active connections # Maximum 512 total active connections
QS_SrvMaxConn 512 QS_SrvMaxConn 512
# Disable keep-alive when 400 connections active # Disable keep-alive when 400 connections active
QS_SrvMaxConnClose 400 QS_SrvMaxConnClose 400
# Minimum data rates: 200 bytes/sec download, 1500 upload # Minimum data rates: 200 bytes/sec download, 1500 upload
QS_SrvMinDataRate 200 1500 QS_SrvMinDataRate 200 1500
# Protect resource-intensive endpoints # Protect resource-intensive endpoints
QS_LocRequestLimit "/login" 5 QS_LocRequestLimit "/login" 5
QS_LocRequestLimit "/admin" 3 QS_LocRequestLimit "/admin" 3
@ -264,15 +264,15 @@ http {
limit_conn_zone $binary_remote_addr zone=addr:10m; limit_conn_zone $binary_remote_addr zone=addr:10m;
limit_req_zone $binary_remote_addr zone=general:10m rate=10r/s; limit_req_zone $binary_remote_addr zone=general:10m rate=10r/s;
limit_req_zone $binary_remote_addr zone=login:10m rate=1r/s; limit_req_zone $binary_remote_addr zone=login:10m rate=1r/s;
server { server {
# Global: 10 concurrent connections per IP # Global: 10 concurrent connections per IP
limit_conn addr 10; limit_conn addr 10;
location / { location / {
limit_req zone=general burst=20 nodelay; limit_req zone=general burst=20 nodelay;
} }
location /login { location /login {
# Aggressive limits for authentication # Aggressive limits for authentication
limit_conn addr 3; limit_conn addr 3;
@ -521,20 +521,20 @@ SEC("xdp")
int ddos_protection(struct xdp_md *ctx) { int ddos_protection(struct xdp_md *ctx) {
void *data_end = (void *)(long)ctx->data_end; void *data_end = (void *)(long)ctx->data_end;
void *data = (void *)(long)ctx->data; void *data = (void *)(long)ctx->data;
// Parse Ethernet header // Parse Ethernet header
struct ethhdr *eth = data; struct ethhdr *eth = data;
if ((void *)(eth + 1) > data_end) return XDP_PASS; if ((void *)(eth + 1) > data_end) return XDP_PASS;
if (eth->h_proto != __constant_htons(ETH_P_IP)) return XDP_PASS; if (eth->h_proto != __constant_htons(ETH_P_IP)) return XDP_PASS;
// Parse IP header // Parse IP header
struct iphdr *iph = (void *)(eth + 1); struct iphdr *iph = (void *)(eth + 1);
if ((void *)(iph + 1) > data_end) return XDP_PASS; if ((void *)(iph + 1) > data_end) return XDP_PASS;
__u32 src_ip = iph->saddr; __u32 src_ip = iph->saddr;
struct rate_limit_entry *entry = bpf_map_lookup_elem(&rate_limit_map, &src_ip); struct rate_limit_entry *entry = bpf_map_lookup_elem(&rate_limit_map, &src_ip);
__u64 current_time = bpf_ktime_get_ns(); __u64 current_time = bpf_ktime_get_ns();
if (entry) { if (entry) {
if (current_time - entry->last_update < TIME_WINDOW_NS) { if (current_time - entry->last_update < TIME_WINDOW_NS) {
entry->packet_count++; entry->packet_count++;
@ -1099,7 +1099,7 @@ groups:
for: 2m for: 2m
annotations: annotations:
summary: "High SYN rate detected" summary: "High SYN rate detected"
- alert: ConntrackTableFull - alert: ConntrackTableFull
expr: node_nf_conntrack_entries / node_nf_conntrack_entries_limit > 0.9 expr: node_nf_conntrack_entries / node_nf_conntrack_entries_limit > 0.9
for: 5m for: 5m

View File

@ -269,14 +269,14 @@ For complex dependencies, Nix provides reproducible static builds.
let let
pkgs = import <nixpkgs> {}; pkgs = import <nixpkgs> {};
pkgsMusl = pkgs.pkgsMusl; pkgsMusl = pkgs.pkgsMusl;
staticLibs = [ staticLibs = [
(pkgsMusl.gmp6.override { withStatic = true; }) (pkgsMusl.gmp6.override { withStatic = true; })
pkgsMusl.zlib.static pkgsMusl.zlib.static
(pkgsMusl.libffi.overrideAttrs (old: { dontDisableStatic = true; })) (pkgsMusl.libffi.overrideAttrs (old: { dontDisableStatic = true; }))
(pkgsMusl.openssl.override { static = true; }) (pkgsMusl.openssl.override { static = true; })
]; ];
in pkgsMusl.haskellPackages.aenebris.overrideAttrs (old: { in pkgsMusl.haskellPackages.aenebris.overrideAttrs (old: {
enableSharedExecutables = false; enableSharedExecutables = false;
enableSharedLibraries = false; enableSharedLibraries = false;
@ -384,7 +384,7 @@ packages: .
package * package *
ghc-options: -O2 -split-sections ghc-options: -O2 -split-sections
gcc-options: -Os -ffunction-sections -fdata-sections gcc-options: -Os -ffunction-sections -fdata-sections
package aenebris package aenebris
ld-options: -Wl,--gc-sections ld-options: -Wl,--gc-sections
ghc-options: -funbox-strict-fields -fllvm ghc-options: -funbox-strict-fields -fllvm
@ -442,13 +442,13 @@ spec:
spec: spec:
# Service account for RBAC # Service account for RBAC
serviceAccountName: aenebris serviceAccountName: aenebris
# Security context # Security context
securityContext: securityContext:
runAsNonRoot: true runAsNonRoot: true
runAsUser: 1000 runAsUser: 1000
fsGroup: 1000 fsGroup: 1000
# Topology spread for high availability # Topology spread for high availability
topologySpreadConstraints: topologySpreadConstraints:
- maxSkew: 1 - maxSkew: 1
@ -463,7 +463,7 @@ spec:
labelSelector: labelSelector:
matchLabels: matchLabels:
app: aenebris app: aenebris
# Node affinity for dedicated nodes # Node affinity for dedicated nodes
affinity: affinity:
nodeAffinity: nodeAffinity:
@ -474,7 +474,7 @@ spec:
- key: workload-type - key: workload-type
operator: In operator: In
values: [proxy, edge] values: [proxy, edge]
# Pod anti-affinity # Pod anti-affinity
podAntiAffinity: podAntiAffinity:
preferredDuringSchedulingIgnoredDuringExecution: preferredDuringSchedulingIgnoredDuringExecution:
@ -484,15 +484,15 @@ spec:
matchLabels: matchLabels:
app: aenebris app: aenebris
topologyKey: kubernetes.io/hostname topologyKey: kubernetes.io/hostname
# Graceful shutdown - CRITICAL for WebSockets # Graceful shutdown - CRITICAL for WebSockets
terminationGracePeriodSeconds: 120 terminationGracePeriodSeconds: 120
containers: containers:
- name: aenebris - name: aenebris
image: ghcr.io/yourorg/aenebris:1.0.0 image: ghcr.io/yourorg/aenebris:1.0.0
imagePullPolicy: IfNotPresent imagePullPolicy: IfNotPresent
# Ports # Ports
ports: ports:
- name: http - name: http
@ -504,7 +504,7 @@ spec:
- name: metrics - name: metrics
containerPort: 9090 containerPort: 9090
protocol: TCP protocol: TCP
# Haskell RTS configuration for high performance # Haskell RTS configuration for high performance
command: command:
- /usr/local/bin/aenebris - /usr/local/bin/aenebris
@ -519,14 +519,14 @@ spec:
- "-RTS" - "-RTS"
- "--config" - "--config"
- "/etc/aenebris/config.yaml" - "/etc/aenebris/config.yaml"
# Environment variables # Environment variables
env: env:
- name: LOG_LEVEL - name: LOG_LEVEL
value: "info" value: "info"
- name: METRICS_PORT - name: METRICS_PORT
value: "9090" value: "9090"
# Resource requests and limits # Resource requests and limits
resources: resources:
requests: requests:
@ -535,7 +535,7 @@ spec:
limits: limits:
cpu: "8000m" # Burst to 8 cores cpu: "8000m" # Burst to 8 cores
memory: "4Gi" # Hard limit memory: "4Gi" # Hard limit
# Volume mounts # Volume mounts
volumeMounts: volumeMounts:
- name: config - name: config
@ -549,7 +549,7 @@ spec:
readOnly: true readOnly: true
- name: tmp - name: tmp
mountPath: /tmp mountPath: /tmp
# Startup probe (slow initial startup) # Startup probe (slow initial startup)
startupProbe: startupProbe:
httpGet: httpGet:
@ -561,7 +561,7 @@ spec:
timeoutSeconds: 1 timeoutSeconds: 1
failureThreshold: 30 # 60 seconds max startup time failureThreshold: 30 # 60 seconds max startup time
successThreshold: 1 successThreshold: 1
# Liveness probe (detect deadlocks) # Liveness probe (detect deadlocks)
livenessProbe: livenessProbe:
httpGet: httpGet:
@ -573,7 +573,7 @@ spec:
timeoutSeconds: 2 timeoutSeconds: 2
failureThreshold: 3 failureThreshold: 3
successThreshold: 1 successThreshold: 1
# Readiness probe (traffic management) # Readiness probe (traffic management)
readinessProbe: readinessProbe:
httpGet: httpGet:
@ -585,7 +585,7 @@ spec:
timeoutSeconds: 2 timeoutSeconds: 2
failureThreshold: 2 failureThreshold: 2
successThreshold: 1 successThreshold: 1
# PreStop hook for graceful shutdown # PreStop hook for graceful shutdown
lifecycle: lifecycle:
preStop: preStop:
@ -599,7 +599,7 @@ spec:
kill -TERM 1 kill -TERM 1
# Wait for connections to drain (110s, leaving 10s buffer) # Wait for connections to drain (110s, leaving 10s buffer)
sleep 110 sleep 110
# Security context # Security context
securityContext: securityContext:
allowPrivilegeEscalation: false allowPrivilegeEscalation: false
@ -609,7 +609,7 @@ spec:
capabilities: capabilities:
drop: ["ALL"] drop: ["ALL"]
add: ["NET_BIND_SERVICE"] add: ["NET_BIND_SERVICE"]
volumes: volumes:
- name: config - name: config
configMap: configMap:
@ -683,7 +683,7 @@ spec:
target: target:
type: Utilization type: Utilization
averageUtilization: 70 averageUtilization: 70
# Memory-based scaling # Memory-based scaling
- type: Resource - type: Resource
resource: resource:
@ -691,7 +691,7 @@ spec:
target: target:
type: Utilization type: Utilization
averageUtilization: 80 averageUtilization: 80
# Custom metric: requests per second # Custom metric: requests per second
- type: Pods - type: Pods
pods: pods:
@ -700,7 +700,7 @@ spec:
target: target:
type: AverageValue type: AverageValue
averageValue: "2000" # 2k req/s per pod averageValue: "2000" # 2k req/s per pod
# Custom metric: active connections # Custom metric: active connections
- type: Pods - type: Pods
pods: pods:
@ -709,7 +709,7 @@ spec:
target: target:
type: AverageValue type: AverageValue
averageValue: "1000" # 1k connections per pod averageValue: "1000" # 1k connections per pod
# Scaling behavior # Scaling behavior
behavior: behavior:
scaleUp: scaleUp:
@ -971,7 +971,7 @@ probes:
timeoutSeconds: 1 timeoutSeconds: 1
failureThreshold: 30 failureThreshold: 30
successThreshold: 1 successThreshold: 1
liveness: liveness:
httpGet: httpGet:
path: /healthz path: /healthz
@ -981,7 +981,7 @@ probes:
timeoutSeconds: 2 timeoutSeconds: 2
failureThreshold: 3 failureThreshold: 3
successThreshold: 1 successThreshold: 1
readiness: readiness:
httpGet: httpGet:
path: /ready path: /ready
@ -1009,12 +1009,12 @@ config:
enabled: true enabled: true
path: "/health" path: "/health"
interval: "10s" interval: "10s"
rateLimit: rateLimit:
enabled: true enabled: true
requestsPerSecond: 1000 requestsPerSecond: 1000
burst: 2000 burst: 2000
tls: tls:
enabled: true enabled: true
minVersion: "1.2" minVersion: "1.2"
@ -1022,7 +1022,7 @@ config:
- "TLS_AES_256_GCM_SHA384" - "TLS_AES_256_GCM_SHA384"
- "TLS_AES_128_GCM_SHA256" - "TLS_AES_128_GCM_SHA256"
- "TLS_CHACHA20_POLY1305_SHA256" - "TLS_CHACHA20_POLY1305_SHA256"
websocket: websocket:
enabled: true enabled: true
pingInterval: "30s" pingInterval: "30s"
@ -1041,7 +1041,7 @@ tls:
secrets: secrets:
upstreamCredentials: upstreamCredentials:
existingSecret: "aenebris-upstream-creds" existingSecret: "aenebris-upstream-creds"
# Network policies # Network policies
networkPolicy: networkPolicy:
enabled: true enabled: true
@ -1496,7 +1496,7 @@ spec:
timeoutSeconds: 1 timeoutSeconds: 1
failureThreshold: 30 # 5s + (30 * 2s) = 65s max failureThreshold: 30 # 5s + (30 * 2s) = 65s max
successThreshold: 1 successThreshold: 1
# Liveness probe - detects deadlocks # Liveness probe - detects deadlocks
livenessProbe: livenessProbe:
httpGet: httpGet:
@ -1511,7 +1511,7 @@ spec:
timeoutSeconds: 2 timeoutSeconds: 2
failureThreshold: 3 # Restart after 30s of failures failureThreshold: 3 # Restart after 30s of failures
successThreshold: 1 successThreshold: 1
# Readiness probe - traffic management # Readiness probe - traffic management
readinessProbe: readinessProbe:
httpGet: httpGet:
@ -1541,15 +1541,15 @@ lifecycle:
- | - |
# Stop accepting new connections # Stop accepting new connections
echo "Graceful shutdown initiated at $(date)" echo "Graceful shutdown initiated at $(date)"
# Send SIGTERM to application (it should stop accepting) # Send SIGTERM to application (it should stop accepting)
kill -TERM 1 kill -TERM 1
# Wait for existing connections to drain # Wait for existing connections to drain
# (110 seconds, leaving 10s buffer before SIGKILL) # (110 seconds, leaving 10s buffer before SIGKILL)
echo "Waiting for connections to drain..." echo "Waiting for connections to drain..."
sleep 110 sleep 110
echo "Shutdown complete at $(date)" echo "Shutdown complete at $(date)"
``` ```
@ -1575,23 +1575,23 @@ main :: IO ()
main = do main = do
shutdownFlag <- newTVarIO False shutdownFlag <- newTVarIO False
setupGracefulShutdown shutdownFlag setupGracefulShutdown shutdownFlag
-- Start server in separate thread -- Start server in separate thread
serverThread <- async $ runServer shutdownFlag serverThread <- async $ runServer shutdownFlag
-- Wait for shutdown signal -- Wait for shutdown signal
atomically $ do atomically $ do
shutdown <- readTVar shutdownFlag shutdown <- readTVar shutdownFlag
unless shutdown retry unless shutdown retry
putStrLn "Stopping server, draining connections..." putStrLn "Stopping server, draining connections..."
-- Stop accepting new connections -- Stop accepting new connections
stopAcceptingConnections stopAcceptingConnections
-- Wait for existing connections to complete -- Wait for existing connections to complete
waitForConnectionsDrain 110 -- 110 seconds waitForConnectionsDrain 110 -- 110 seconds
putStrLn "All connections drained, exiting" putStrLn "All connections drained, exiting"
waitForConnectionsDrain :: Int -> IO () waitForConnectionsDrain :: Int -> IO ()
@ -1617,10 +1617,10 @@ metadata:
# AWS NLB # AWS NLB
service.beta.kubernetes.io/aws-load-balancer-connection-draining-enabled: "true" service.beta.kubernetes.io/aws-load-balancer-connection-draining-enabled: "true"
service.beta.kubernetes.io/aws-load-balancer-connection-draining-timeout: "120" service.beta.kubernetes.io/aws-load-balancer-connection-draining-timeout: "120"
# GCP # GCP
cloud.google.com/neg: '{"ingress": true}' cloud.google.com/neg: '{"ingress": true}'
spec: spec:
sessionAffinity: ClientIP sessionAffinity: ClientIP
sessionAffinityConfig: sessionAffinityConfig:
@ -1783,7 +1783,7 @@ sum(websocket_connections_total) by (pod)
rate(container_cpu_cfs_throttled_seconds_total{pod=~"aenebris.*"}[5m]) rate(container_cpu_cfs_throttled_seconds_total{pod=~"aenebris.*"}[5m])
# Memory usage vs limit # Memory usage vs limit
container_memory_usage_bytes{pod=~"aenebris.*"} / container_memory_usage_bytes{pod=~"aenebris.*"} /
container_spec_memory_limit_bytes{pod=~"aenebris.*"} container_spec_memory_limit_bytes{pod=~"aenebris.*"}
``` ```
@ -1853,14 +1853,14 @@ kubectl delete certificate aenebris-tls -n production
This comprehensive deployment guide provides a production-ready foundation for deploying Ᾰenebris on Kubernetes. The architecture achieves: This comprehensive deployment guide provides a production-ready foundation for deploying Ᾰenebris on Kubernetes. The architecture achieves:
**Ultra-minimal Docker images** (15-50MB) via multi-stage builds and static linking **Ultra-minimal Docker images** (15-50MB) via multi-stage builds and static linking
**High availability** with topology spread, pod disruption budgets, and anti-affinity **High availability** with topology spread, pod disruption budgets, and anti-affinity
**Zero-downtime deployments** through graceful shutdown and connection draining **Zero-downtime deployments** through graceful shutdown and connection draining
**Automated TLS management** with cert-manager **Automated TLS management** with cert-manager
**Secure secrets handling** via External Secrets Operator and Sealed Secrets **Secure secrets handling** via External Secrets Operator and Sealed Secrets
**Production-grade monitoring** with Prometheus and Grafana **Production-grade monitoring** with Prometheus and Grafana
**Dynamic scaling** from 5 to 50 replicas based on traffic **Dynamic scaling** from 5 to 50 replicas based on traffic
**WebSocket support** with proper connection management **WebSocket support** with proper connection management
**Next Steps:** **Next Steps:**
1. Customize values.yaml for your environment 1. Customize values.yaml for your environment

View File

@ -194,7 +194,7 @@ bingExample = do
### WaiProxyResponse type ### WaiProxyResponse type
```haskell ```haskell
data WaiProxyResponse data WaiProxyResponse
= WPRResponse WAI.Response -- Return custom response = WPRResponse WAI.Response -- Return custom response
| WPRProxyDest ProxyDest -- Forward to destination | WPRProxyDest ProxyDest -- Forward to destination
| WPRModifiedRequest WAI.Request ProxyDest -- Modify then forward | WPRModifiedRequest WAI.Request ProxyDest -- Modify then forward
@ -245,7 +245,7 @@ proxyApp manager request respond = do
else give chunk >> loop else give chunk >> loop
in loop in loop
} }
-- Make the request and forward response -- Make the request and forward response
httpLbs proxiedReq manager >>= \response -> httpLbs proxiedReq manager >>= \response ->
respond $ responseLBS respond $ responseLBS
@ -257,7 +257,7 @@ proxyApp manager request respond = do
fixHeaders :: RequestHeaders -> RequestHeaders fixHeaders :: RequestHeaders -> RequestHeaders
fixHeaders = filter $ \(name, _) -> name `notElem` hopByHopHeaders fixHeaders = filter $ \(name, _) -> name `notElem` hopByHopHeaders
where where
hopByHopHeaders = hopByHopHeaders =
[ "connection", "keep-alive", "proxy-authenticate" [ "connection", "keep-alive", "proxy-authenticate"
, "proxy-authorization", "te", "trailers" , "proxy-authorization", "te", "trailers"
, "transfer-encoding", "upgrade" , "transfer-encoding", "upgrade"
@ -266,7 +266,7 @@ fixHeaders = filter $ \(name, _) -> name `notElem` hopByHopHeaders
fixResponseHeaders :: ResponseHeaders -> ResponseHeaders fixResponseHeaders :: ResponseHeaders -> ResponseHeaders
fixResponseHeaders = filter $ \(name, _) -> name `notElem` hopByHopHeaders fixResponseHeaders = filter $ \(name, _) -> name `notElem` hopByHopHeaders
where where
hopByHopHeaders = hopByHopHeaders =
[ "connection", "keep-alive", "proxy-authenticate" [ "connection", "keep-alive", "proxy-authenticate"
, "proxy-authorization", "te", "trailers" , "proxy-authorization", "te", "trailers"
, "transfer-encoding", "upgrade" , "transfer-encoding", "upgrade"
@ -286,7 +286,7 @@ main = do
```haskell ```haskell
-- Add X-Forwarded-For header -- Add X-Forwarded-For header
addForwardedFor :: Request -> RequestHeaders -> RequestHeaders addForwardedFor :: Request -> RequestHeaders -> RequestHeaders
addForwardedFor req headers = addForwardedFor req headers =
let clientIP = show (remoteHost req) let clientIP = show (remoteHost req)
existing = lookup "X-Forwarded-For" headers existing = lookup "X-Forwarded-For" headers
newValue = case existing of newValue = case existing of
@ -369,7 +369,7 @@ import Network.HTTP.Types
import Data.ByteString.Builder (byteString) import Data.ByteString.Builder (byteString)
app :: Application app :: Application
app _req respond = respond $ app _req respond = respond $
responseStream status200 [("Content-Type", "text/plain")] $ \write flush -> do responseStream status200 [("Content-Type", "text/plain")] $ \write flush -> do
write $ byteString "Hello\n" write $ byteString "Hello\n"
flush flush
@ -388,10 +388,10 @@ import Data.Function (fix)
import Control.Monad (unless) import Control.Monad (unless)
streamFileApp :: Application streamFileApp :: Application
streamFileApp _req respond = streamFileApp _req respond =
withBinaryFile "largefile.txt" ReadMode $ \h -> withBinaryFile "largefile.txt" ReadMode $ \h ->
respond $ responseStream status200 [("Content-Type", "text/plain")] $ respond $ responseStream status200 [("Content-Type", "text/plain")] $
\chunk _flush -> \chunk _flush ->
fix $ \loop -> do fix $ \loop -> do
bs <- B.hGetSome h 4096 -- Only 4KB in memory at once bs <- B.hGetSome h 4096 -- Only 4KB in memory at once
unless (B.null bs) $ do unless (B.null bs) $ do
@ -414,17 +414,17 @@ import qualified Data.ByteString.Char8 as C8
sseApp :: Application sseApp :: Application
sseApp _req sendResponse = sendResponse $ sseApp _req sendResponse = sendResponse $
responseStream status200 responseStream status200
[("Content-Type", "text/event-stream"), [("Content-Type", "text/event-stream"),
("Cache-Control", "no-cache"), ("Cache-Control", "no-cache"),
("Connection", "keep-alive")] ("Connection", "keep-alive")]
myStream myStream
myStream :: (Builder -> IO ()) -> IO () -> IO () myStream :: (Builder -> IO ()) -> IO () -> IO ()
myStream send flush = do myStream send flush = do
send $ byteString "data: Starting streaming response.\n\n" send $ byteString "data: Starting streaming response.\n\n"
flush flush
forM_ [1..50 :: Int] $ \i -> do forM_ [1..50 :: Int] $ \i -> do
threadDelay 1000000 -- 1 second threadDelay 1000000 -- 1 second
send $ byteString "data: Message " <> byteString (C8.pack $ show i) <> byteString "\n\n" send $ byteString "data: Message " <> byteString (C8.pack $ show i) <> byteString "\n\n"
@ -464,10 +464,10 @@ main = do
-- Pure operations -- Pure operations
result <- runConduit $ yieldMany [1..10] .| sumC result <- runConduit $ yieldMany [1..10] .| sumC
print result -- 55 print result -- 55
-- File operations -- File operations
runConduitRes $ runConduitRes $
sourceFile "input.txt" .| sourceFile "input.txt" .|
sinkFile "output.txt" sinkFile "output.txt"
``` ```
@ -480,8 +480,8 @@ import qualified Data.Conduit.Binary as CB
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
conduitFileApp :: Application conduitFileApp :: Application
conduitFileApp _req respond = conduitFileApp _req respond =
respond $ responseStream status200 [("Content-Type", "text/plain")] $ respond $ responseStream status200 [("Content-Type", "text/plain")] $
\write flush -> runResourceT $ do \write flush -> runResourceT $ do
CB.sourceFile "largefile.txt" $$ CB.mapM_ $ \chunk -> liftIO $ do CB.sourceFile "largefile.txt" $$ CB.mapM_ $ \chunk -> liftIO $ do
write (byteString chunk) write (byteString chunk)
@ -498,8 +498,8 @@ import qualified Data.Conduit.List as CL
streamFromDB :: Handler () streamFromDB :: Handler ()
streamFromDB = do streamFromDB = do
-- selectSource returns a conduit Source -- selectSource returns a conduit Source
selectSource [] [] selectSource [] []
$$ CL.mapM_ $ \(Entity _ record) -> $$ CL.mapM_ $ \(Entity _ record) ->
liftIO $ processRecord record liftIO $ processRecord record
``` ```
@ -531,8 +531,8 @@ import Data.Conduit
import qualified Data.Conduit.List as CL import qualified Data.Conduit.List as CL
sumConduit :: IO Int sumConduit :: IO Int
sumConduit = runConduit $ sumConduit = runConduit $
yieldMany [1..10] .| yieldMany [1..10] .|
CL.fold (+) 0 CL.fold (+) 0
``` ```
@ -589,17 +589,17 @@ generateCSV write flush = do
-- Header -- Header
write $ byteString "id,name,value\n" write $ byteString "id,name,value\n"
flush flush
-- Generate 1 million rows without buffering -- Generate 1 million rows without buffering
forM_ [1..1000000] $ \i -> do forM_ [1..1000000] $ \i -> do
let row = byteString $ C8.pack $ let row = byteString $ C8.pack $
show i ++ ",Item" ++ show i ++ "," ++ show (i * 100) ++ "\n" show i ++ ",Item" ++ show i ++ "," ++ show (i * 100) ++ "\n"
write row write row
when (i `mod` 1000 == 0) flush when (i `mod` 1000 == 0) flush
csvApp :: Application csvApp :: Application
csvApp _req respond = respond $ csvApp _req respond = respond $
responseStream status200 responseStream status200
[("Content-Type", "text/csv"), [("Content-Type", "text/csv"),
("Content-Disposition", "attachment; filename=data.csv")] ("Content-Disposition", "attachment; filename=data.csv")]
generateCSV generateCSV
@ -611,19 +611,19 @@ csvApp _req respond = respond $
processWithProgress :: (Builder -> IO ()) -> IO () -> IO () processWithProgress :: (Builder -> IO ()) -> IO () -> IO ()
processWithProgress write flush = do processWithProgress write flush = do
let total = 100 let total = 100
forM_ [1..total] $ \i -> do forM_ [1..total] $ \i -> do
threadDelay 100000 -- Simulate work threadDelay 100000 -- Simulate work
let progress = byteString $ let progress = byteString $
"data: {\"progress\": " <> "data: {\"progress\": " <>
byteString (C8.pack $ show i) <> byteString (C8.pack $ show i) <>
", \"total\": " <> ", \"total\": " <>
byteString (C8.pack $ show total) <> byteString (C8.pack $ show total) <>
"}\n\n" "}\n\n"
write progress write progress
flush flush
write $ byteString "data: {\"status\": \"complete\"}\n\n" write $ byteString "data: {\"status\": \"complete\"}\n\n"
flush flush
``` ```
@ -725,7 +725,7 @@ application state pending = do
client = (T.drop (T.length prefix) msg, conn) client = (T.drop (T.length prefix) msg, conn)
disconnect = do disconnect = do
s <- modifyMVar state $ \s -> s <- modifyMVar state $ \s ->
let s' = filter ((/= fst client) . fst) s let s' = filter ((/= fst client) . fst) s
in return (s', s') in return (s', s')
broadcast (fst client <> " disconnected") s broadcast (fst client <> " disconnected") s
@ -798,9 +798,9 @@ advancedTLS = do
} }
, onInsecure = DenyInsecure "This server requires HTTPS" , onInsecure = DenyInsecure "This server requires HTTPS"
} }
warpOpts = setPort 443 $ setHost "0.0.0.0" $ defaultSettings warpOpts = setPort 443 $ setHost "0.0.0.0" $ defaultSettings
runTLS tlsOpts warpOpts app runTLS tlsOpts warpOpts app
validateClientCert :: CertificateChain -> IO CertificateUsage validateClientCert :: CertificateChain -> IO CertificateUsage
@ -821,7 +821,7 @@ secureTLS = do
let tlsOpts = tlsSettings "cert.pem" "key.pem" let tlsOpts = tlsSettings "cert.pem" "key.pem"
warpOpts = setPort 443 defaultSettings warpOpts = setPort 443 defaultSettings
wsApp = websocketsOr WS.defaultConnectionOptions wsHandler httpApp wsApp = websocketsOr WS.defaultConnectionOptions wsHandler httpApp
runTLS tlsOpts warpOpts wsApp runTLS tlsOpts warpOpts wsApp
wsHandler :: WS.ServerApp wsHandler :: WS.ServerApp
@ -844,7 +844,7 @@ dynamicCerts = do
Just "example.com" -> loadCredentials "example.pem" "example-key.pem" Just "example.com" -> loadCredentials "example.pem" "example-key.pem"
Just "other.com" -> loadCredentials "other.pem" "other-key.pem" Just "other.com" -> loadCredentials "other.pem" "other-key.pem"
_ -> loadCredentials "default.pem" "default-key.pem" _ -> loadCredentials "default.pem" "default-key.pem"
runTLS tlsOpts defaultSettings app runTLS tlsOpts defaultSettings app
loadCredentials :: FilePath -> FilePath -> IO Credentials loadCredentials :: FilePath -> FilePath -> IO Credentials
@ -909,7 +909,7 @@ gracefulShutdown = do
let settings = setInstallShutdownHandler shutdownHandler let settings = setInstallShutdownHandler shutdownHandler
$ setGracefulShutdownTimeout (Just 30) -- 30 seconds max $ setGracefulShutdownTimeout (Just 30) -- 30 seconds max
$ setPort 8080 defaultSettings $ setPort 8080 defaultSettings
runSettings settings app runSettings settings app
where where
shutdownHandler closeSocket = do shutdownHandler closeSocket = do
@ -935,7 +935,7 @@ gracefulShutdown = do
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
productionSettings :: Settings productionSettings :: Settings
productionSettings = productionSettings =
setPort 443 setPort 443
$ setHost "*" $ setHost "*"
$ setOnOpen onOpen $ setOnOpen onOpen
@ -953,13 +953,13 @@ productionSettings =
onOpen sockAddr = do onOpen sockAddr = do
putStrLn $ "Connection: " ++ show sockAddr putStrLn $ "Connection: " ++ show sockAddr
return True return True
onClose sockAddr = onClose sockAddr =
putStrLn $ "Closed: " ++ show sockAddr putStrLn $ "Closed: " ++ show sockAddr
onException _ e = onException _ e =
putStrLn $ "Exception: " ++ show e putStrLn $ "Exception: " ++ show e
shutdownHandler closeSocket = do shutdownHandler closeSocket = do
_ <- installHandler sigTERM (Catch closeSocket) Nothing _ <- installHandler sigTERM (Catch closeSocket) Nothing
_ <- installHandler sigINT (Catch closeSocket) Nothing _ <- installHandler sigINT (Catch closeSocket) Nothing
@ -1023,16 +1023,16 @@ websocketHandler pending = do
-- HTTP handler (including streaming) -- HTTP handler (including streaming)
httpHandler :: Application httpHandler :: Application
httpHandler req respond = httpHandler req respond =
case pathInfo req of case pathInfo req of
["stream"] -> respond $ streamingResponse ["stream"] -> respond $ streamingResponse
["ws"] -> respond $ responseLBS status404 [] "Use WebSocket protocol" ["ws"] -> respond $ responseLBS status404 [] "Use WebSocket protocol"
_ -> respond $ responseLBS status200 [] "Hello HTTP" _ -> respond $ responseLBS status200 [] "Hello HTTP"
streamingResponse :: Response streamingResponse :: Response
streamingResponse = responseStream streamingResponse = responseStream
status200 status200
[("Content-Type", "text/event-stream")] [("Content-Type", "text/event-stream")]
$ \write flush -> forever $ do $ \write flush -> forever $ do
threadDelay 1000000 threadDelay 1000000
write $ byteString "data: tick\n\n" write $ byteString "data: tick\n\n"
@ -1067,10 +1067,10 @@ server {
proxy_set_header Upgrade $http_upgrade; proxy_set_header Upgrade $http_upgrade;
proxy_set_header Connection $connection_upgrade; proxy_set_header Connection $connection_upgrade;
proxy_set_header Host $host; proxy_set_header Host $host;
# Critical: disable buffering # Critical: disable buffering
proxy_buffering off; proxy_buffering off;
# Increase timeouts # Increase timeouts
proxy_read_timeout 86400s; proxy_read_timeout 86400s;
proxy_send_timeout 86400s; proxy_send_timeout 86400s;
@ -1080,11 +1080,11 @@ server {
location /stream/ { location /stream/ {
proxy_pass http://localhost:8002; proxy_pass http://localhost:8002;
proxy_http_version 1.1; proxy_http_version 1.1;
# Critical: disable buffering for streaming # Critical: disable buffering for streaming
proxy_buffering off; proxy_buffering off;
proxy_cache off; proxy_cache off;
# Keep connection alive # Keep connection alive
proxy_set_header Connection ''; proxy_set_header Connection '';
proxy_set_header Cache-Control 'no-cache'; proxy_set_header Cache-Control 'no-cache';
@ -1242,9 +1242,9 @@ For unidirectional streaming, SSE offers advantages:
```haskell ```haskell
sseHandler :: Application sseHandler :: Application
sseHandler _req respond = respond $ sseHandler _req respond = respond $
responseStream status200 responseStream status200
[("Content-Type", "text/event-stream"), [("Content-Type", "text/event-stream"),
("Cache-Control", "no-cache")] ("Cache-Control", "no-cache")]
$ \write flush -> forever $ do $ \write flush -> forever $ do
threadDelay 1000000 threadDelay 1000000
write $ byteString "data: update\n\n" write $ byteString "data: update\n\n"

View File

@ -163,14 +163,14 @@ server {
listen 443 ssl; listen 443 ssl;
listen [::]:443 ssl; listen [::]:443 ssl;
http2 on; http2 on;
# HTTP/3 over UDP # HTTP/3 over UDP
listen 443 quic reuseport; listen 443 quic reuseport;
listen [::]:443 quic reuseport; listen [::]:443 quic reuseport;
ssl_protocols TLSv1.2 TLSv1.3; ssl_protocols TLSv1.2 TLSv1.3;
add_header Alt-Svc 'h3=":443"; ma=86400' always; add_header Alt-Svc 'h3=":443"; ma=86400' always;
location / { location / {
proxy_pass http://localhost:3000; # Warp proxy_pass http://localhost:3000; # Warp
proxy_http_version 1.1; proxy_http_version 1.1;
@ -221,7 +221,7 @@ import Control.Monad.Trans.Resource
app :: Application app :: Application
app req respond = runResourceT $ do app req respond = runResourceT $ do
(releaseKey, handle) <- allocate (releaseKey, handle) <- allocate
(openFile "data.txt" ReadMode) (openFile "data.txt" ReadMode)
hClose hClose
content <- liftIO $ hGetContents handle content <- liftIO $ hGetContents handle

View File

@ -88,7 +88,7 @@ data Backend = Backend
} }
trackConnection :: Backend -> IO a -> IO a trackConnection :: Backend -> IO a -> IO a
trackConnection backend action = trackConnection backend action =
bracket_ bracket_
(atomically $ modifyTVar' (activeConnections backend) (+1)) (atomically $ modifyTVar' (activeConnections backend) (+1))
(atomically $ modifyTVar' (activeConnections backend) (subtract 1)) (atomically $ modifyTVar' (activeConnections backend) (subtract 1))
@ -110,7 +110,7 @@ This pattern **composes naturally with health checks** - the STM transaction can
import Control.Concurrent.LoadDistribution import Control.Concurrent.LoadDistribution
lb <- evenlyDistributed (return $ Set.fromList backends) lb <- evenlyDistributed (return $ Set.fromList backends)
withResource lb $ \maybeBackend -> withResource lb $ \maybeBackend ->
case maybeBackend of case maybeBackend of
Just backend -> proxyRequest backend Just backend -> proxyRequest backend
Nothing -> handleNoBackends Nothing -> handleNoBackends
@ -132,18 +132,18 @@ data WeightedBackend a = WeightedBackend
smoothWeightedSelect :: [WeightedBackend a] -> IO a smoothWeightedSelect :: [WeightedBackend a] -> IO a
smoothWeightedSelect backends = atomically $ do smoothWeightedSelect backends = atomically $ do
-- Increase all current weights by their base weights -- Increase all current weights by their base weights
forM_ backends $ \wb -> forM_ backends $ \wb ->
modifyTVar' (currentWeight wb) (+ weight wb) modifyTVar' (currentWeight wb) (+ weight wb)
-- Find backend with maximum current weight -- Find backend with maximum current weight
weights <- mapM (readTVar . currentWeight) backends weights <- mapM (readTVar . currentWeight) backends
let maxWeight = maximum weights let maxWeight = maximum weights
selected = backends !! fromJust (findIndex (== maxWeight) weights) selected = backends !! fromJust (findIndex (== maxWeight) weights)
-- Reduce selected backend's current weight by total -- Reduce selected backend's current weight by total
let totalWeight = sum (map weight backends) let totalWeight = sum (map weight backends)
modifyTVar' (currentWeight selected) (subtract totalWeight) modifyTVar' (currentWeight selected) (subtract totalWeight)
return $ backend selected return $ backend selected
``` ```
@ -188,7 +188,7 @@ data BackendState = BackendState
-- BAD: Touches many TVars in single transaction -- BAD: Touches many TVars in single transaction
countAllConnections :: [Backend] -> STM Int countAllConnections :: [Backend] -> STM Int
countAllConnections backends = countAllConnections backends =
sum <$> mapM (readTVar . activeConns) backends sum <$> mapM (readTVar . activeConns) backends
-- GOOD: Maintain aggregate counter -- GOOD: Maintain aggregate counter
@ -281,7 +281,7 @@ The `retry` primitive is STM's killer feature - **threads automatically block un
badPattern = atomically $ do badPattern = atomically $ do
val <- expensiveComputation -- Recomputed on every retry! val <- expensiveComputation -- Recomputed on every retry!
tvar <- readTVar someTVar tvar <- readTVar someTVar
-- GOOD: Pure computation outside -- GOOD: Pure computation outside
goodPattern = do goodPattern = do
let val = expensiveComputation let val = expensiveComputation
@ -299,7 +299,7 @@ goodPattern = do
```haskell ```haskell
-- Update multiple backend states atomically -- Update multiple backend states atomically
updateHealthChecks :: [Backend] -> [(Backend, Bool)] -> STM () updateHealthChecks :: [Backend] -> [(Backend, Bool)] -> STM ()
updateHealthChecks backends results = updateHealthChecks backends results =
forM_ results $ \(backend, isHealthy) -> forM_ results $ \(backend, isHealthy) ->
writeTVar (healthy backend) isHealthy writeTVar (healthy backend) isHealthy
``` ```
@ -344,7 +344,7 @@ performHealthCheck manager config backend = do
req <- parseRequest url req <- parseRequest url
response <- httpLbs req manager response <- httpLbs req manager
return $ statusCode (responseStatus response) == 200 return $ statusCode (responseStatus response) == 200
return $ fromMaybe False result return $ fromMaybe False result
``` ```
@ -362,13 +362,13 @@ import Control.Monad (forever)
healthCheckLoop :: Manager -> HealthCheckConfig -> [Backend] -> IO () healthCheckLoop :: Manager -> HealthCheckConfig -> [Backend] -> IO ()
healthCheckLoop manager config backends = forever $ do healthCheckLoop manager config backends = forever $ do
-- Check all backends concurrently -- Check all backends concurrently
results <- mapConcurrently results <- mapConcurrently
(performHealthCheck manager config) (performHealthCheck manager config)
backends backends
-- Update backend states -- Update backend states
zipWithM_ (updateBackendState config) backends results zipWithM_ (updateBackendState config) backends results
-- Wait for next interval -- Wait for next interval
threadDelay (hcInterval config * 1000000) threadDelay (hcInterval config * 1000000)
@ -414,7 +414,7 @@ updateBackendState config backend healthy = atomically $ do
state <- readTVar (backendState backend) state <- readTVar (backendState backend)
failures <- readTVar (backendFailures backend) failures <- readTVar (backendFailures backend)
successes <- readTVar (backendSuccesses backend) successes <- readTVar (backendSuccesses backend)
case (state, healthy) of case (state, healthy) of
(Healthy, False) -> do (Healthy, False) -> do
let newFailures = failures + 1 let newFailures = failures + 1
@ -422,22 +422,22 @@ updateBackendState config backend healthy = atomically $ do
when (newFailures >= hcMaxFailures config) $ do when (newFailures >= hcMaxFailures config) $ do
writeTVar (backendState backend) Unhealthy writeTVar (backendState backend) Unhealthy
writeTVar (backendFailures backend) 0 writeTVar (backendFailures backend) 0
(Unhealthy, True) -> do (Unhealthy, True) -> do
writeTVar (backendState backend) Recovering writeTVar (backendState backend) Recovering
writeTVar (backendSuccesses backend) 1 writeTVar (backendSuccesses backend) 1
(Recovering, True) -> do (Recovering, True) -> do
let newSuccesses = successes + 1 let newSuccesses = successes + 1
writeTVar (backendSuccesses backend) newSuccesses writeTVar (backendSuccesses backend) newSuccesses
when (newSuccesses >= hcRecoveryAttempts config) $ do when (newSuccesses >= hcRecoveryAttempts config) $ do
writeTVar (backendState backend) Healthy writeTVar (backendState backend) Healthy
writeTVar (backendSuccesses backend) 0 writeTVar (backendSuccesses backend) 0
(Recovering, False) -> do (Recovering, False) -> do
writeTVar (backendState backend) Unhealthy writeTVar (backendState backend) Unhealthy
writeTVar (backendSuccesses backend) 0 writeTVar (backendSuccesses backend) 0
_ -> return () _ -> return ()
``` ```
@ -458,15 +458,15 @@ testBreaker = undefined
proxyWithCircuitBreaker :: Backend -> Request -> IO Response proxyWithCircuitBreaker :: Backend -> Request -> IO Response
proxyWithCircuitBreaker backend req = do proxyWithCircuitBreaker backend req = do
cbConf <- initialBreakerState cbConf <- initialBreakerState
result <- flip runReaderT cbConf $ result <- flip runReaderT cbConf $
withBreaker testBreaker $ liftIO $ forwardRequest backend req withBreaker testBreaker $ liftIO $ forwardRequest backend req
case result of case result of
Left (CircuitBreakerClosed msg) -> Left (CircuitBreakerClosed msg) ->
-- Circuit open, return cached response or error -- Circuit open, return cached response or error
return $ errorResponse 503 "Service Temporarily Unavailable" return $ errorResponse 503 "Service Temporarily Unavailable"
Right response -> Right response ->
return response return response
``` ```
@ -521,7 +521,7 @@ exponentialBackoffWithJitter config action = go 0 (initialDelay config)
```haskell ```haskell
import Control.Retry import Control.Retry
recovering recovering
(exponentialBackoff 50000 <> limitRetries 5) (exponentialBackoff 50000 <> limitRetries 5)
[const $ Handler $ \e -> return (isRetryable e)] [const $ Handler $ \e -> return (isRetryable e)]
(\_ -> performHealthCheck backend) (\_ -> performHealthCheck backend)
@ -554,16 +554,16 @@ proxyApp :: ProxyConfig -> Application
proxyApp config req respond = do proxyApp config req respond = do
mBackend <- selectHealthyBackend (pcBalancer config) mBackend <- selectHealthyBackend (pcBalancer config)
case mBackend of case mBackend of
Nothing -> Nothing ->
respond $ responseLBS status503 [] "No healthy backends available" respond $ responseLBS status503 [] "No healthy backends available"
Just backend -> Just backend ->
waiProxyTo waiProxyTo
(\_ -> return $ WPRProxyDest (ProxyDest (\_ -> return $ WPRProxyDest (ProxyDest
(backendHost backend) (backendHost backend)
(backendPort backend))) (backendPort backend)))
defaultOnExc defaultOnExc
(pcManager config) (pcManager config)
req req
respond respond
``` ```
@ -585,7 +585,7 @@ import Network.Wai (Middleware, mapResponseHeaders)
-- Add load balancer info header -- Add load balancer info header
addBackendHeader :: Backend -> Middleware addBackendHeader :: Backend -> Middleware
addBackendHeader backend app req respond = addBackendHeader backend app req respond =
app req $ respond . mapResponseHeaders app req $ respond . mapResponseHeaders
((hBackend, encodeUtf8 $ backendId backend) :) ((hBackend, encodeUtf8 $ backendId backend) :)
-- Connection tracking middleware -- Connection tracking middleware
@ -593,18 +593,18 @@ trackingMiddleware :: ServerMetrics -> Middleware
trackingMiddleware metrics app req respond = do trackingMiddleware metrics app req respond = do
atomically $ modifyTVar' (activeConnections metrics) (+1) atomically $ modifyTVar' (activeConnections metrics) (+1)
atomically $ modifyTVar' (totalRequests metrics) (+1) atomically $ modifyTVar' (totalRequests metrics) (+1)
let respond' res = do let respond' res = do
atomically $ modifyTVar' (activeConnections metrics) (subtract 1) atomically $ modifyTVar' (activeConnections metrics) (subtract 1)
respond res respond res
app req respond' `onException` app req respond' `onException`
atomically (modifyTVar' (errorCount metrics) (+1)) atomically (modifyTVar' (errorCount metrics) (+1))
-- Compose middleware -- Compose middleware
main = do main = do
config <- initProxyConfig config <- initProxyConfig
let app = trackingMiddleware metrics let app = trackingMiddleware metrics
$ proxyApp config $ proxyApp config
run 8000 app run 8000 app
``` ```
@ -624,7 +624,7 @@ main = do
**Compile-time optimizations**: **Compile-time optimizations**:
```cabal ```cabal
ghc-options: -Wall -O2 -threaded ghc-options: -Wall -O2 -threaded
-rtsopts -with-rtsopts=-N -rtsopts -with-rtsopts=-N
-fspec-constr -fspecialise -fspec-constr -fspecialise
-funbox-strict-fields -funbox-strict-fields
@ -709,7 +709,7 @@ data ProxyConfig = ProxyConfig
-- Backend selection dispatcher -- Backend selection dispatcher
selectBackend :: ProxyConfig -> IO (Maybe Backend) selectBackend :: ProxyConfig -> IO (Maybe Backend)
selectBackend config = selectBackend config =
case strategy config of case strategy config of
RoundRobin -> selectRoundRobin config RoundRobin -> selectRoundRobin config
LeastConnections -> selectLeastConnections config LeastConnections -> selectLeastConnections config
@ -722,7 +722,7 @@ selectRoundRobin config = do
len = V.length backends' len = V.length backends'
idx <- atomicModifyIORef' (rrCounter config) $ \i -> idx <- atomicModifyIORef' (rrCounter config) $ \i ->
((i + 1) `mod` len, i) ((i + 1) `mod` len, i)
-- Find next healthy backend -- Find next healthy backend
findHealthy backends' idx len findHealthy backends' idx len
where where
@ -733,7 +733,7 @@ selectRoundRobin config = do
isHealthy <- atomically $ (== Healthy) <$> readTVar (state backend) isHealthy <- atomically $ (== Healthy) <$> readTVar (state backend)
if isHealthy if isHealthy
then return (Just backend) then return (Just backend)
else findHealthy backends' else findHealthy backends'
((start + 1) `mod` V.length backends') ((start + 1) `mod` V.length backends')
(remaining - 1) (remaining - 1)
@ -756,24 +756,24 @@ selectLeastConnections config = do
selectWeightedRR :: ProxyConfig -> IO (Maybe Backend) selectWeightedRR :: ProxyConfig -> IO (Maybe Backend)
selectWeightedRR config = atomically $ do selectWeightedRR config = atomically $ do
let backends' = V.toList (backends config) let backends' = V.toList (backends config)
-- Increase current weights -- Increase current weights
forM_ backends' $ \wb -> forM_ backends' $ \wb ->
modifyTVar' (currentWeight wb) (+ backendWeight wb) modifyTVar' (currentWeight wb) (+ backendWeight wb)
-- Select backend with max current weight -- Select backend with max current weight
weights <- mapM (readTVar . currentWeight) backends' weights <- mapM (readTVar . currentWeight) backends'
let maxWeight = maximum weights let maxWeight = maximum weights
selected = backends' !! fromJust (findIndex (== maxWeight) weights) selected = backends' !! fromJust (findIndex (== maxWeight) weights)
-- Check health -- Check health
isHealthy <- (== Healthy) <$> readTVar (state selected) isHealthy <- (== Healthy) <$> readTVar (state selected)
guard isHealthy guard isHealthy
-- Reduce selected backend's current weight -- Reduce selected backend's current weight
let totalWeight = sum (map backendWeight backends') let totalWeight = sum (map backendWeight backends')
modifyTVar' (currentWeight selected) (subtract totalWeight) modifyTVar' (currentWeight selected) (subtract totalWeight)
return selected return selected
-- Main proxy application -- Main proxy application
@ -781,17 +781,17 @@ proxyApp :: ProxyConfig -> Application
proxyApp config req respond = do proxyApp config req respond = do
mBackend <- selectBackend config mBackend <- selectBackend config
case mBackend of case mBackend of
Nothing -> Nothing ->
respond $ responseLBS status503 [] "No healthy backends" respond $ responseLBS status503 [] "No healthy backends"
Just backend -> do Just backend -> do
-- Track connection -- Track connection
atomically $ modifyTVar' (activeConns backend) (+1) atomically $ modifyTVar' (activeConns backend) (+1)
let dest = ProxyDest (backendHost backend) (backendPort backend) let dest = ProxyDest (backendHost backend) (backendPort backend)
respond' res = do respond' res = do
atomically $ modifyTVar' (activeConns backend) (subtract 1) atomically $ modifyTVar' (activeConns backend) (subtract 1)
respond res respond res
waiProxyTo waiProxyTo
(\_ -> return $ WPRProxyDest dest) (\_ -> return $ WPRProxyDest dest)
defaultOnExc defaultOnExc
@ -807,14 +807,14 @@ healthCheckLoop manager backends = forever $ do
threadDelay 10000000 -- 10 seconds threadDelay 10000000 -- 10 seconds
where where
checkHealth mgr backend = do checkHealth mgr backend = do
let url = "http://" <> backendHost backend <> ":" let url = "http://" <> backendHost backend <> ":"
<> show (backendPort backend) <> "/health" <> show (backendPort backend) <> "/health"
result <- timeout 2000000 $ do result <- timeout 2000000 $ do
req <- parseRequest (unpack url) req <- parseRequest (unpack url)
response <- httpLbs req mgr response <- httpLbs req mgr
return $ statusCode (responseStatus response) == 200 return $ statusCode (responseStatus response) == 200
return $ fromMaybe False result return $ fromMaybe False result
updateHealth backend healthy = atomically $ do updateHealth backend healthy = atomically $ do
currentState <- readTVar (state backend) currentState <- readTVar (state backend)
failureCount <- readTVar (failures backend) failureCount <- readTVar (failures backend)
@ -838,7 +838,7 @@ initProxyConfig specs strat = do
manager <- newTlsManager manager <- newTlsManager
counter <- newIORef 0 counter <- newIORef 0
checker <- async $ healthCheckLoop manager (V.toList backends) checker <- async $ healthCheckLoop manager (V.toList backends)
return ProxyConfig return ProxyConfig
{ backends = backends { backends = backends
, strategy = strat , strategy = strat
@ -859,18 +859,18 @@ initProxyConfig specs strat = do
-- Main entry point -- Main entry point
main :: IO () main :: IO ()
main = do main = do
let backendSpecs = let backendSpecs =
[ BackendSpec "localhost" 8001 5 [ BackendSpec "localhost" 8001 5
, BackendSpec "localhost" 8002 1 , BackendSpec "localhost" 8002 1
, BackendSpec "localhost" 8003 1 , BackendSpec "localhost" 8003 1
] ]
config <- initProxyConfig backendSpecs SmoothWeightedRR config <- initProxyConfig backendSpecs SmoothWeightedRR
let settings = setPort 8000 let settings = setPort 8000
$ setTimeout 30 $ setTimeout 30
$ defaultSettings $ defaultSettings
putStrLn "Load balancing proxy started on port 8000" putStrLn "Load balancing proxy started on port 8000"
runSettings settings (proxyApp config) runSettings settings (proxyApp config)
``` ```
@ -939,8 +939,8 @@ import Test.DejaFu
testNoDeadlock :: IO () testNoDeadlock :: IO ()
testNoDeadlock = autocheck $ do testNoDeadlock = autocheck $ do
balancer <- setup balancer <- setup
concurrently_ concurrently_
(selectBackend balancer) (selectBackend balancer)
(selectBackend balancer) (selectBackend balancer)
``` ```

View File

@ -30,13 +30,13 @@ import Foreign.C.Types
import System.Posix.Types (Fd(..)) import System.Posix.Types (Fd(..))
foreign import ccall unsafe "splice" foreign import ccall unsafe "splice"
c_splice :: CInt -> Ptr CLong -> CInt -> Ptr CLong c_splice :: CInt -> Ptr CLong -> CInt -> Ptr CLong
-> CSize -> CUInt -> IO CSsize -> CSize -> CUInt -> IO CSsize
splice :: Fd -> Fd -> Int -> [SpliceFlag] -> IO Int splice :: Fd -> Fd -> Int -> [SpliceFlag] -> IO Int
splice (Fd fdIn) (Fd fdOut) len flags = do splice (Fd fdIn) (Fd fdOut) len flags = do
let cflags = foldr (.|.) 0 [f | SpliceFlag f <- flags] let cflags = foldr (.|.) 0 [f | SpliceFlag f <- flags]
result <- c_splice fdIn nullPtr fdOut nullPtr result <- c_splice fdIn nullPtr fdOut nullPtr
(fromIntegral len) cflags (fromIntegral len) cflags
if result == -1 if result == -1
then throwErrno "splice" then throwErrno "splice"
@ -59,10 +59,10 @@ The `simple-sendfile` package powers Warp's high-performance static file serving
```haskell ```haskell
import Network.Sendfile import Network.Sendfile
sendfileWithHeader :: Socket -> FilePath -> FileRange sendfileWithHeader :: Socket -> FilePath -> FileRange
-> IO () -> [ByteString] -> IO () -> IO () -> [ByteString] -> IO ()
-- Sends headers and file data efficiently -- Sends headers and file data efficiently
sendfileWithHeader sock path (PartOfFile offset len) sendfileWithHeader sock path (PartOfFile offset len)
tickle headers tickle headers
``` ```
@ -77,7 +77,7 @@ spliceWithRetry :: Fd -> Fd -> Int -> IO ()
spliceWithRetry fdIn fdOut chunkSize = loop spliceWithRetry fdIn fdOut chunkSize = loop
where where
loop = do loop = do
result <- try $ splice fdIn fdOut chunkSize result <- try $ splice fdIn fdOut chunkSize
[spliceNonBlock, spliceMore] [spliceNonBlock, spliceMore]
case result of case result of
Right 0 -> return () -- EOF Right 0 -> return () -- EOF
@ -111,15 +111,15 @@ Conversion costs between variants matter significantly. `toStrict` forces entire
```haskell ```haskell
import Data.ByteString.Builder import Data.ByteString.Builder
buildHttpResponse :: Int -> [(ByteString, ByteString)] buildHttpResponse :: Int -> [(ByteString, ByteString)]
-> LazyByteString -> LazyByteString -> LazyByteString -> LazyByteString
buildHttpResponse status headers body = toLazyByteString builder buildHttpResponse status headers body = toLazyByteString builder
where where
builder = statusLine <> headerLines builder = statusLine <> headerLines
<> byteString "\r\n" <> lazyByteString body <> byteString "\r\n" <> lazyByteString body
statusLine = byteString "HTTP/1.1 " <> intDec status statusLine = byteString "HTTP/1.1 " <> intDec status
<> byteString " OK\r\n" <> byteString " OK\r\n"
headerLines = mconcat headerLines = mconcat
[ byteString k <> byteString ": " <> byteString v <> byteString "\r\n" [ byteString k <> byteString ": " <> byteString v <> byteString "\r\n"
| (k, v) <- headers ] | (k, v) <- headers ]
``` ```
@ -134,7 +134,7 @@ import Data.Pool
createBackendPool :: HostName -> PortNumber -> IO (Pool Socket) createBackendPool :: HostName -> PortNumber -> IO (Pool Socket)
createBackendPool host port = do createBackendPool host port = do
capabilities <- getNumCapabilities capabilities <- getNumCapabilities
newPool $ newPool $
defaultPoolConfig defaultPoolConfig
(connectBackend host port) -- Create function (connectBackend host port) -- Create function
close -- Destroy function close -- Destroy function
@ -228,7 +228,7 @@ Interpreting results requires understanding latency distribution. The `--latency
``` ```
Latency Distribution Latency Distribution
50% 635.91us 50% 635.91us
75% 712.34us 75% 712.34us
90% 1.04ms 90% 1.04ms
99% 2.87ms 99% 2.87ms
``` ```
@ -385,7 +385,7 @@ ThreadScope displays CPU activity across cores, spark creation/conversion (for p
**Profiling workflow progresses systematically**: **Profiling workflow progresses systematically**:
1. **Baseline measurement** with `-O2 +RTS -s` establishes initial performance 1. **Baseline measurement** with `-O2 +RTS -s` establishes initial performance
2. **Time profiling** with `-prof -fprof-late +RTS -p` identifies CPU hotspots 2. **Time profiling** with `-prof -fprof-late +RTS -p` identifies CPU hotspots
3. **Memory profiling** with `-hd -l` and eventlog2html reveals allocation patterns 3. **Memory profiling** with `-hd -l` and eventlog2html reveals allocation patterns
4. **Detailed investigation** using info table profiling for exact source locations 4. **Detailed investigation** using info table profiling for exact source locations
5. **Iterative optimization** applying fixes and re-profiling to verify improvements 5. **Iterative optimization** applying fixes and re-profiling to verify improvements
@ -401,7 +401,7 @@ Successful optimization follows priority order: algorithms trump micro-optimizat
**Compilation optimization checklist**: **Compilation optimization checklist**:
- [ ] Use `-O` or `-O2` for production builds - [ ] Use `-O` or `-O2` for production builds
- [ ] Add `-fllvm` for numeric-intensive code after benchmarking - [ ] Add `-fllvm` for numeric-intensive code after benchmarking
- [ ] Enable `-threaded` for concurrent programs - [ ] Enable `-threaded` for concurrent programs
- [ ] Include `-rtsopts` to allow runtime tuning - [ ] Include `-rtsopts` to allow runtime tuning
- [ ] Set `-with-rtsopts=-N` for automatic parallelism - [ ] Set `-with-rtsopts=-N` for automatic parallelism
- [ ] Use `optimization: 2` in cabal.project, not `ghc-options` - [ ] Use `optimization: 2` in cabal.project, not `ghc-options`
@ -483,7 +483,7 @@ import System.IO
data ProxyConfig = ProxyConfig data ProxyConfig = ProxyConfig
{ listenPort :: PortNumber { listenPort :: PortNumber
, targetHost :: HostName , targetHost :: HostName
, targetPort :: PortNumber , targetPort :: PortNumber
, poolStripes :: Int , poolStripes :: Int
, poolPerStripe :: Int , poolPerStripe :: Int
@ -492,8 +492,8 @@ data ProxyConfig = ProxyConfig
-- Create backend connection pool -- Create backend connection pool
createBackendPool :: ProxyConfig -> IO (Pool Socket) createBackendPool :: ProxyConfig -> IO (Pool Socket)
createBackendPool config = createBackendPool config =
newPool $ newPool $
defaultPoolConfig defaultPoolConfig
(connectBackend (targetHost config) (targetPort config)) (connectBackend (targetHost config) (targetPort config))
close close
@ -503,7 +503,7 @@ createBackendPool config =
connectBackend :: HostName -> PortNumber -> IO Socket connectBackend :: HostName -> PortNumber -> IO Socket
connectBackend host port = do connectBackend host port = do
addr:_ <- getAddrInfo addr:_ <- getAddrInfo
(Just defaultHints { addrSocketType = Stream }) (Just defaultHints { addrSocketType = Stream })
(Just host) (Just $ show port) (Just host) (Just $ show port)
sock <- socket (addrFamily addr) Stream defaultProtocol sock <- socket (addrFamily addr) Stream defaultProtocol
@ -517,18 +517,18 @@ runProxy :: ProxyConfig -> IO ()
runProxy config = do runProxy config = do
pool <- createBackendPool config pool <- createBackendPool config
addr:_ <- getAddrInfo addr:_ <- getAddrInfo
(Just defaultHints (Just defaultHints
{ addrSocketType = Stream { addrSocketType = Stream
, addrFlags = [AI_PASSIVE] }) , addrFlags = [AI_PASSIVE] })
Nothing (Just $ show $ listenPort config) Nothing (Just $ show $ listenPort config)
sock <- socket (addrFamily addr) Stream defaultProtocol sock <- socket (addrFamily addr) Stream defaultProtocol
setSocketOption sock ReuseAddr 1 setSocketOption sock ReuseAddr 1
bind sock (addrAddress addr) bind sock (addrAddress addr)
listen sock 128 listen sock 128
putStrLn $ "Proxy listening on port " ++ show (listenPort config) putStrLn $ "Proxy listening on port " ++ show (listenPort config)
forever $ do forever $ do
(client, clientAddr) <- accept sock (client, clientAddr) <- accept sock
forkIO $ handleClient pool client forkIO $ handleClient pool client
@ -538,27 +538,27 @@ runProxy config = do
handleClient :: Pool Socket -> Socket -> IO () handleClient :: Pool Socket -> Socket -> IO ()
handleClient pool client = do handleClient pool client = do
done <- newEmptyMVar done <- newEmptyMVar
withResource pool $ \backend -> do withResource pool $ \backend -> do
-- Bidirectional zero-copy forwarding -- Bidirectional zero-copy forwarding
let chunkSize = 65536 -- 64KB chunks let chunkSize = 65536 -- 64KB chunks
forkIO $ do forkIO $ do
result <- try $ splice chunkSize (client, Nothing) result <- try $ splice chunkSize (client, Nothing)
(backend, Nothing) (backend, Nothing)
case result of case result of
Left (e :: SomeException) -> Left (e :: SomeException) ->
putStrLn $ "Client->Backend error: " ++ show e putStrLn $ "Client->Backend error: " ++ show e
Right _ -> return () Right _ -> return ()
putMVar done () putMVar done ()
result <- try $ splice chunkSize (backend, Nothing) result <- try $ splice chunkSize (backend, Nothing)
(client, Nothing) (client, Nothing)
case result of case result of
Left (e :: SomeException) -> Left (e :: SomeException) ->
putStrLn $ "Backend->Client error: " ++ show e putStrLn $ "Backend->Client error: " ++ show e
Right _ -> return () Right _ -> return ()
takeMVar done takeMVar done
main :: IO () main :: IO ()
@ -582,7 +582,7 @@ main = do
import Data.ByteString.Builder import Data.ByteString.Builder
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
buildHttpResponse :: Int -> [(ByteString, ByteString)] buildHttpResponse :: Int -> [(ByteString, ByteString)]
-> BL.ByteString -> BL.ByteString -> BL.ByteString -> BL.ByteString
buildHttpResponse status headers body = toLazyByteString $ buildHttpResponse status headers body = toLazyByteString $
mconcat mconcat
@ -591,7 +591,7 @@ buildHttpResponse status headers body = toLazyByteString $
, byteString " " , byteString " "
, statusText status , statusText status
, byteString "\r\n" , byteString "\r\n"
, mconcat [ byteString k <> byteString ": " , mconcat [ byteString k <> byteString ": "
<> byteString v <> byteString "\r\n" <> byteString v <> byteString "\r\n"
| (k, v) <- headers ] | (k, v) <- headers ]
, byteString "\r\n" , byteString "\r\n"
@ -599,7 +599,7 @@ buildHttpResponse status headers body = toLazyByteString $
] ]
where where
statusText 200 = byteString "OK" statusText 200 = byteString "OK"
statusText 404 = byteString "Not Found" statusText 404 = byteString "Not Found"
statusText 500 = byteString "Internal Server Error" statusText 500 = byteString "Internal Server Error"
statusText _ = byteString "Unknown" statusText _ = byteString "Unknown"
``` ```
@ -616,14 +616,14 @@ parseRequestLine :: ByteString -> Maybe (ByteString, ByteString, ByteString)
parseRequestLine bs = do parseRequestLine bs = do
let (method, rest1) = BS.break (== space) bs let (method, rest1) = BS.break (== space) bs
guard (not $ BS.null rest1) guard (not $ BS.null rest1)
let rest2 = BS.drop 1 rest1 let rest2 = BS.drop 1 rest1
(path, rest3) = BS.break (== space) rest2 (path, rest3) = BS.break (== space) rest2
guard (not $ BS.null rest3) guard (not $ BS.null rest3)
let rest4 = BS.drop 1 rest3 let rest4 = BS.drop 1 rest3
(version, _) = BS.break (== cr) rest4 (version, _) = BS.break (== cr) rest4
return (method, path, version) return (method, path, version)
where where
space = 32; cr = 13 space = 32; cr = 13
@ -635,11 +635,11 @@ parseHeaders = go . BC.lines
go [] = [] go [] = []
go (line:rest) go (line:rest)
| BS.null line = [] | BS.null line = []
| otherwise = | otherwise =
case BC.break (== ':') line of case BC.break (== ':') line of
(key, value) (key, value)
| BS.null value -> go rest | BS.null value -> go rest
| otherwise -> | otherwise ->
let val = BS.dropWhile (== 32) (BS.drop 1 value) let val = BS.dropWhile (== 32) (BS.drop 1 value)
in (key, val) : go rest in (key, val) : go rest
``` ```

View File

@ -210,16 +210,16 @@ RateLimit: "default";r=0;t=60
async function fetchWithRetry(url, maxRetries = 3) { async function fetchWithRetry(url, maxRetries = 3) {
for (let attempt = 0; attempt < maxRetries; attempt++) { for (let attempt = 0; attempt < maxRetries; attempt++) {
const res = await fetch(url); const res = await fetch(url);
if (res.status === 429) { if (res.status === 429) {
const retryAfter = res.headers.get('retry-after'); const retryAfter = res.headers.get('retry-after');
const delay = parseInt(retryAfter) * 1000 || (1000 * Math.pow(2, attempt)); const delay = parseInt(retryAfter) * 1000 || (1000 * Math.pow(2, attempt));
const jitter = delay * 0.2 * (Math.random() - 0.5); const jitter = delay * 0.2 * (Math.random() - 0.5);
await sleep(delay + jitter); await sleep(delay + jitter);
continue; continue;
} }
return res; return res;
} }
throw new Error('Max retries exceeded'); throw new Error('Max retries exceeded');

View File

@ -34,7 +34,7 @@ For a Haskell reverse proxy, the recommended approach uses WAI's `responseRaw` c
```haskell ```haskell
handleWebSocketProxy :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived handleWebSocketProxy :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
handleWebSocketProxy req respond = respond $ handleWebSocketProxy req respond = respond $
responseRaw (rawProxy targetHost targetPort) backupResponse responseRaw (rawProxy targetHost targetPort) backupResponse
``` ```
@ -83,7 +83,7 @@ The **recommended hybrid approach**: forward all ping/pong frames transparently
Per-connection state: Per-connection state:
last_activity: timestamp last_activity: timestamp
pong_expected: bool pong_expected: bool
Periodic check (every 10s): Periodic check (every 10s):
if pong_expected and (now - ping_sent_at) > pong_timeout: if pong_expected and (now - ping_sent_at) > pong_timeout:
terminate_connection("pong timeout") terminate_connection("pong timeout")
@ -104,7 +104,7 @@ HAProxy's model provides the blueprint for proper timeout architecture:
``` ```
defaults defaults
timeout client 25s # HTTP inactivity timeout client 25s # HTTP inactivity
timeout server 25s # HTTP inactivity timeout server 25s # HTTP inactivity
timeout connect 5s # TCP establishment timeout connect 5s # TCP establishment
timeout tunnel 3600s # WebSocket/upgraded connections timeout tunnel 3600s # WebSocket/upgraded connections
``` ```
@ -129,7 +129,7 @@ Auto-detect connection type via `Connection: Upgrade` + `Upgrade: websocket` hea
The connection state machine should explicitly model different phases: The connection state machine should explicitly model different phases:
```haskell ```haskell
data ConnectionState data ConnectionState
= HttpRequest -- Initial HTTP parsing = HttpRequest -- Initial HTTP parsing
| HttpResponse -- Response from upstream | HttpResponse -- Response from upstream
| ProtocolUpgrade -- Detected upgrade, awaiting 101 | ProtocolUpgrade -- Detected upgrade, awaiting 101
@ -155,14 +155,14 @@ transitionState :: ConnectionState -> Event -> ConnectionState
**Recommended Haskell stack:** **Recommended Haskell stack:**
- `wai` + `warp`: HTTP server foundation - `wai` + `warp`: HTTP server foundation
- `streaming-commons`: TCP client connections - `streaming-commons`: TCP client connections
- `splice`: Zero-copy socket forwarding on Linux - `splice`: Zero-copy socket forwarding on Linux
- `async`: Concurrent bidirectional copy with `race_` - `async`: Concurrent bidirectional copy with `race_`
- `websockets` + `wai-websockets`: Only if frame-level access needed - `websockets` + `wai-websockets`: Only if frame-level access needed
**Architecture flow:** **Architecture flow:**
``` ```
Listener → HTTP Parser → Route Match → Listener → HTTP Parser → Route Match →
├─ Regular HTTP → Buffer Pool → Upstream → Response Buffer → Client ├─ Regular HTTP → Buffer Pool → Upstream → Response Buffer → Client
├─ WebSocket → Upgrade Handler → Bidirectional Tunnel (splice) ├─ WebSocket → Upgrade Handler → Bidirectional Tunnel (splice)
└─ SSE/Stream → Detect Header → Immediate Flush → Client └─ SSE/Stream → Detect Header → Immediate Flush → Client

View File

@ -91,10 +91,10 @@ tlsClient hostname port = do
addr:_ <- getAddrInfo Nothing (Just hostname) (Just port) addr:_ <- getAddrInfo Nothing (Just hostname) (Just port)
sock <- socket (addrFamily addr) Stream defaultProtocol sock <- socket (addrFamily addr) Stream defaultProtocol
connect sock (addrAddress addr) connect sock (addrAddress addr)
-- Configure TLS parameters -- Configure TLS parameters
let params = (defaultParamsClient hostname "") let params = (defaultParamsClient hostname "")
{ clientSupported = def { clientSupported = def
{ supportedCiphers = ciphersuite_default { supportedCiphers = ciphersuite_default
, supportedVersions = [TLS13, TLS12] , supportedVersions = [TLS13, TLS12]
, supportedGroups = [X25519, P256] , supportedGroups = [X25519, P256]
@ -103,16 +103,16 @@ tlsClient hostname port = do
{ sharedCAStore = systemStore { sharedCAStore = systemStore
} }
} }
-- Perform handshake -- Perform handshake
ctx <- contextNew sock params ctx <- contextNew sock params
handshake ctx handshake ctx
-- Send HTTP request -- Send HTTP request
sendData ctx "GET / HTTP/1.1\r\nHost: example.com\r\n\r\n" sendData ctx "GET / HTTP/1.1\r\nHost: example.com\r\n\r\n"
response <- recvData ctx response <- recvData ctx
print response print response
-- Clean shutdown -- Clean shutdown
bye ctx bye ctx
close sock close sock
@ -131,8 +131,8 @@ import qualified Network.TLS as TLS
import Network.TLS.Extra.Cipher import Network.TLS.Extra.Cipher
app :: Application app :: Application
app _ respond = app _ respond =
respond $ responseLBS status200 respond $ responseLBS status200
[("Content-Type", "text/plain") [("Content-Type", "text/plain")
,("Strict-Transport-Security", "max-age=31536000; includeSubDomains")] ,("Strict-Transport-Security", "max-age=31536000; includeSubDomains")]
"Secure HTTPS Server" "Secure HTTPS Server"
@ -144,11 +144,11 @@ main = do
, tlsCiphers = ciphersuite_strong , tlsCiphers = ciphersuite_strong
, onInsecure = DenyInsecure "HTTPS required" , onInsecure = DenyInsecure "HTTPS required"
} }
warpConfig = defaultSettings warpConfig = defaultSettings
& setPort 443 & setPort 443
& setHost "0.0.0.0" & setHost "0.0.0.0"
putStrLn "HTTPS server on :443" putStrLn "HTTPS server on :443"
runTLS tlsConfig warpConfig app runTLS tlsConfig warpConfig app
``` ```
@ -169,14 +169,14 @@ validateCertificate certFile hostname = do
-- Load certificate chain -- Load certificate chain
certs <- readSignedObject certFile certs <- readSignedObject certFile
let chain = CertificateChain certs let chain = CertificateChain certs
-- Get system CA store -- Get system CA store
store <- getSystemCertificateStore store <- getSystemCertificateStore
-- Validate with default checks -- Validate with default checks
let cache = exceptionValidationCache [] let cache = exceptionValidationCache []
failures <- validateDefault store cache (hostname, ":443") chain failures <- validateDefault store cache (hostname, ":443") chain
case failures of case failures of
[] -> putStrLn "✓ Certificate valid" >> return True [] -> putStrLn "✓ Certificate valid" >> return True
errs -> do errs -> do
@ -206,10 +206,10 @@ initializeKeys :: CertConfig -> IO ()
initializeKeys cfg = do initializeKeys cfg = do
accountExists <- doesFileExist (accountKey cfg) accountExists <- doesFileExist (accountKey cfg)
domainExists <- doesFileExist (domainKey cfg) domainExists <- doesFileExist (domainKey cfg)
unless accountExists $ unless accountExists $
callCommand $ "openssl genrsa 4096 > " ++ accountKey cfg callCommand $ "openssl genrsa 4096 > " ++ accountKey cfg
unless domainExists $ unless domainExists $
callCommand $ "openssl genrsa 4096 > " ++ domainKey cfg callCommand $ "openssl genrsa 4096 > " ++ domainKey cfg
@ -337,7 +337,7 @@ import qualified Network.TLS as TLS
customTlsManager :: IO Manager customTlsManager :: IO Manager
customTlsManager = do customTlsManager = do
let tlsParams = (TLS.defaultParamsClient "example.com" "") let tlsParams = (TLS.defaultParamsClient "example.com" "")
{ TLS.clientSupported = def { TLS.clientSupported = def
{ TLS.supportedCiphers = ciphersuite_strong { TLS.supportedCiphers = ciphersuite_strong
, TLS.supportedVersions = [TLS.TLS13, TLS.TLS12] , TLS.supportedVersions = [TLS.TLS13, TLS.TLS12]
} }
@ -346,15 +346,15 @@ customTlsManager = do
} }
} }
tlsSettings = TLSSettings tlsParams tlsSettings = TLSSettings tlsParams
newManager $ mkManagerSettings tlsSettings Nothing newManager $ mkManagerSettings tlsSettings Nothing
customValidation :: CertificateStore -> ValidationCache -> ServiceID customValidation :: CertificateStore -> ValidationCache -> ServiceID
-> CertificateChain -> IO [FailedReason] -> CertificateChain -> IO [FailedReason]
customValidation store cache sid chain = do customValidation store cache sid chain = do
-- Perform standard validation -- Perform standard validation
failures <- validateDefault store cache sid chain failures <- validateDefault store cache sid chain
-- Add custom checks (certificate pinning, etc.) -- Add custom checks (certificate pinning, etc.)
if null failures if null failures
then return [] then return []
@ -375,11 +375,11 @@ loadCredentials hostname = do
main :: IO () main :: IO ()
main = do main = do
let tlsConfig = tlsSettingsSni let tlsConfig = tlsSettingsSni
(return $ Just loadCredentials) (return $ Just loadCredentials)
"default.crt" "default.crt"
"default.key" "default.key"
runTLS tlsConfig defaultSettings app runTLS tlsConfig defaultSettings app
``` ```
@ -392,15 +392,15 @@ import Data.IORef
setupSessionManager :: IO SessionManager setupSessionManager :: IO SessionManager
setupSessionManager = do setupSessionManager = do
sessions <- newIORef Map.empty sessions <- newIORef Map.empty
return SessionManager return SessionManager
{ sessionResume = \sessionID -> do { sessionResume = \sessionID -> do
cache <- readIORef sessions cache <- readIORef sessions
return $ Map.lookup sessionID cache return $ Map.lookup sessionID cache
, sessionEstablish = \sessionID sessionData -> do , sessionEstablish = \sessionID sessionData -> do
modifyIORef' sessions (Map.insert sessionID sessionData) modifyIORef' sessions (Map.insert sessionID sessionData)
, sessionInvalidate = \sessionID -> do , sessionInvalidate = \sessionID -> do
modifyIORef' sessions (Map.delete sessionID) modifyIORef' sessions (Map.delete sessionID)
} }
@ -408,7 +408,7 @@ setupSessionManager = do
clientWithResumption :: HostName -> IO () clientWithResumption :: HostName -> IO ()
clientWithResumption hostname = do clientWithResumption hostname = do
manager <- setupSessionManager manager <- setupSessionManager
let params = (defaultParamsClient hostname "") let params = (defaultParamsClient hostname "")
{ clientShared = def { clientShared = def
{ sharedSessionManager = manager { sharedSessionManager = manager

View File

@ -139,8 +139,8 @@ warn_required_dynamic_aliases = true
py-version = "3.11" py-version = "3.11"
jobs = 4 jobs = 4
load-plugins = [ load-plugins = [
"pylint_pydantic", "pylint_pydantic",
"pylint_per_file_ignores", "pylint_per_file_ignores",
] ]
persistent = true persistent = true
ignore = [ ignore = [
@ -239,4 +239,3 @@ possibly-missing-import = "error"
unused-ignore-comment = "warn" unused-ignore-comment = "warn"
redundant-cast = "warn" redundant-cast = "warn"
undefined-reveal = "warn" undefined-reveal = "warn"

Some files were not shown because too many files have changed in this diff Show More