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:
parent
d6978c4bd3
commit
a7cae3aa0f
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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"
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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)
|
||||||
```
|
```
|
||||||
|
|
||||||
|
|
@ -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
|
||||||
```
|
```
|
||||||
|
|
@ -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');
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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"
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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)
|
||||||
```
|
```
|
||||||
|
|
||||||
|
|
@ -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
|
||||||
```
|
```
|
||||||
|
|
@ -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');
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
|
||||||
|
|
@ -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
Loading…
Reference in New Issue