From d3dd5f2dcb8b4f2d4954bbba5b7c51916cf31b82 Mon Sep 17 00:00:00 2001 From: CarterPerez-dev Date: Wed, 29 Apr 2026 01:46:36 -0400 Subject: [PATCH 1/5] fix(encrypted-p2p-chat): repair dev-up after surrealdb 3.x and pnpm migration - Switch frontend Dockerfiles to pnpm via corepack (project uses pnpm-lock.yaml) - Pin SurrealDB to v3.0.5 and switch datastore URL from `file:` to `rocksdb:` - Add idempotent SurrealDB schema bootstrap on connect to prevent NotFoundError on first SELECT against schemaless tables in 3.x --- .../backend/app/core/surreal_manager.py | 14 ++++++++++++++ .../advanced/encrypted-p2p-chat/compose.yml | 4 ++-- .../conf/docker/dev/vite.docker | 13 +++++++------ .../conf/docker/prod/vite.docker | 13 +++++++------ .../encrypted-p2p-chat/dev.compose.yml | 18 +++++++++--------- 5 files changed, 39 insertions(+), 23 deletions(-) diff --git a/PROJECTS/advanced/encrypted-p2p-chat/backend/app/core/surreal_manager.py b/PROJECTS/advanced/encrypted-p2p-chat/backend/app/core/surreal_manager.py index 1335666e..822aa8a1 100644 --- a/PROJECTS/advanced/encrypted-p2p-chat/backend/app/core/surreal_manager.py +++ b/PROJECTS/advanced/encrypted-p2p-chat/backend/app/core/surreal_manager.py @@ -59,8 +59,22 @@ class SurrealDBManager: settings.SURREAL_DATABASE, ) + await self._init_schema() + self._connected = True + async def _init_schema(self) -> None: + """ + Define tables used by the application so empty SELECTs do not error + """ + schema = """ + DEFINE TABLE IF NOT EXISTS rooms SCHEMALESS; + DEFINE TABLE IF NOT EXISTS room_participants SCHEMALESS; + DEFINE TABLE IF NOT EXISTS messages SCHEMALESS; + DEFINE TABLE IF NOT EXISTS presence SCHEMALESS; + """ + await self.db.query(schema) + async def disconnect(self) -> None: """ Close SurrealDB connection diff --git a/PROJECTS/advanced/encrypted-p2p-chat/compose.yml b/PROJECTS/advanced/encrypted-p2p-chat/compose.yml index e6440e42..f0e26871 100644 --- a/PROJECTS/advanced/encrypted-p2p-chat/compose.yml +++ b/PROJECTS/advanced/encrypted-p2p-chat/compose.yml @@ -22,9 +22,9 @@ services: restart: always surrealdb: - image: surrealdb/surrealdb:latest + image: surrealdb/surrealdb:v3.0.5 container_name: chat-surrealdb - command: start --log trace --user root --pass ${SURREAL_PASSWORD:?SURREAL_PASSWORD required} file:/data/database.db + command: start --log trace --user root --pass ${SURREAL_PASSWORD:?SURREAL_PASSWORD required} rocksdb:/data/database.db environment: - SURREAL_USER=root - SURREAL_PASS=${SURREAL_PASSWORD} diff --git a/PROJECTS/advanced/encrypted-p2p-chat/conf/docker/dev/vite.docker b/PROJECTS/advanced/encrypted-p2p-chat/conf/docker/dev/vite.docker index b238d871..4b51b8c9 100644 --- a/PROJECTS/advanced/encrypted-p2p-chat/conf/docker/dev/vite.docker +++ b/PROJECTS/advanced/encrypted-p2p-chat/conf/docker/dev/vite.docker @@ -1,17 +1,18 @@ -# ©AngelaMos | 2025 -# Development Vite Dockerfile -# HMR dev server, volume mounts for code +# ©AngelaMos | 2026 +# vite.docker FROM node:22-alpine +RUN corepack enable + WORKDIR /app -COPY frontend/package*.json ./ +COPY frontend/package.json frontend/pnpm-lock.yaml ./ -RUN npm ci +RUN pnpm install --frozen-lockfile COPY frontend/ . EXPOSE 5173 -CMD ["npm", "run", "dev", "--", "--host", "0.0.0.0"] +CMD ["pnpm", "run", "dev", "--", "--host", "0.0.0.0"] diff --git a/PROJECTS/advanced/encrypted-p2p-chat/conf/docker/prod/vite.docker b/PROJECTS/advanced/encrypted-p2p-chat/conf/docker/prod/vite.docker index fca89cbc..980b98b0 100644 --- a/PROJECTS/advanced/encrypted-p2p-chat/conf/docker/prod/vite.docker +++ b/PROJECTS/advanced/encrypted-p2p-chat/conf/docker/prod/vite.docker @@ -1,18 +1,19 @@ -# ©AngelaMos | 2025 -# Production Vite Dockerfile -# Multi-stage: build with node, serve with nginx +# ©AngelaMos | 2026 +# vite.docker FROM node:22-alpine AS builder +RUN corepack enable + WORKDIR /app -COPY frontend/package*.json ./ +COPY frontend/package.json frontend/pnpm-lock.yaml ./ -RUN npm ci +RUN pnpm install --frozen-lockfile COPY frontend/ . -RUN npm run build +RUN pnpm run build FROM nginx:alpine diff --git a/PROJECTS/advanced/encrypted-p2p-chat/dev.compose.yml b/PROJECTS/advanced/encrypted-p2p-chat/dev.compose.yml index fbf66017..474fc14a 100644 --- a/PROJECTS/advanced/encrypted-p2p-chat/dev.compose.yml +++ b/PROJECTS/advanced/encrypted-p2p-chat/dev.compose.yml @@ -13,7 +13,7 @@ services: volumes: - postgres_dev_data:/var/lib/postgresql/data ports: - - "${POSTGRES_HOST_PORT:-5432}:5432" + - "${POSTGRES_HOST_PORT:-54332}:5432" networks: - chat_network_dev healthcheck: @@ -23,17 +23,17 @@ services: retries: 5 surrealdb: - image: surrealdb/surrealdb:latest + image: surrealdb/surrealdb:v3.0.5 container_name: chat-surrealdb-dev user: "0:0" - command: start --log trace --user root --pass ${SURREAL_PASSWORD:?SURREAL_PASSWORD required} file:/data/database.db + command: start --log trace --user root --pass ${SURREAL_PASSWORD:?SURREAL_PASSWORD required} rocksdb:/data/database.db environment: - SURREAL_USER=root - SURREAL_PASS=${SURREAL_PASSWORD} volumes: - surreal_dev_data:/data ports: - - "${SURREAL_HOST_PORT:-8001}:8000" + - "${SURREAL_HOST_PORT:-7781}:8000" networks: - chat_network_dev healthcheck: @@ -55,7 +55,7 @@ services: volumes: - redis_dev_data:/data ports: - - "${REDIS_HOST_PORT:-6379}:6379" + - "${REDIS_HOST_PORT:-43434}:6379" networks: - chat_network_dev healthcheck: @@ -82,7 +82,7 @@ services: REDIS_URL: ${REDIS_URL:-redis://redis:6379} RP_ID: ${RP_ID:-localhost} RP_NAME: ${RP_NAME:-Encrypted P2P Chat} - RP_ORIGIN: ${RP_ORIGIN:-http://localhost:82} + RP_ORIGIN: ${RP_ORIGIN:-http://localhost:32342} CORS_ORIGINS: ${CORS_ORIGINS} volumes: - ./backend:/app @@ -98,7 +98,7 @@ services: networks: - chat_network_dev ports: - - "${BACKEND_HOST_PORT:-8000}:8000" + - "${BACKEND_HOST_PORT:-30200}:8000" restart: unless-stopped frontend: @@ -118,14 +118,14 @@ services: networks: - chat_network_dev ports: - - "${FRONTEND_DEV_PORT:-5173}:5173" + - "${FRONTEND_DEV_PORT:-34343}:5173" restart: unless-stopped nginx: image: nginx:alpine container_name: chat-nginx-dev ports: - - "${NGINX_HTTP_PORT:-80}:80" + - "${NGINX_HTTP_PORT:-3234}:80" volumes: - ./conf/nginx/dev.nginx:/etc/nginx/nginx.conf:ro - ./conf/nginx/http.conf:/etc/nginx/http.conf:ro From 2c7e743f57e758f6451d18143881f3563e96a2dd Mon Sep 17 00:00:00 2001 From: CarterPerez-dev Date: Wed, 29 Apr 2026 01:59:36 -0400 Subject: [PATCH 2/5] fix: close audit-pass-1 CRITICAL findings (Findings 1-6) Closes the six CRITICAL findings from the 2026-04-29 audit: - Tunnel.hs (Findings 1+2+4): - connectToBackend now returns Either ConnectError Socket with proper handling of resolution failures, connect timeouts, and connect errors. Replaces the partial `error` call. - parseUpgradeStatus uses safe pattern matching on BS8.lines rather than `head $ BS8.lines` (closes the -Wx-partial warning). - receiveUpgradeResponse is bounded at 16 KB and uses a tight inner loop with strict accumulator (closes the unbounded-read DoS). Adds a 30s timeout via System.Timeout.timeout. - Adds attemptConnect with bracketOnError to ensure socket is closed on partial-failure paths. - File header + remove inline comments. - TLS.hs (Findings 1+15): - loadCredentials replaced with credentialsOrDefault that returns empty credentials and logs to stderr on failure rather than crashing the SNI handler with `error`. - Cipher names updated to non-deprecated forms (cipher13_AES_128_GCM_SHA256 etc.) to clear -Wdeprecations. - File header + remove inline comments. - Connection.hs (supporting Finding 3): - File header + add microsPerSecond and httpOkStatusCode named constants. Add tcUpstreamReadSeconds (default 30) to TimeoutConfig. - Proxy.hs (Findings 1+3): - All five `error` calls replaced with hPutStrLn stderr + exitFailure (matching Main.hs's pattern). - forwardRequest wraps withResponse in System.Timeout.timeout sized off Connection.tcUpstreamReadSeconds. Returns 504 when upstream does not respond within budget. - Main.hs (supporting Finding 3): - HTTP client Manager now configured with managerResponseTimeout set to tcUpstreamReadSeconds * microsPerSecond. Belt-and- suspenders with the application-layer timeout in Proxy.hs. - ML/Loader.hs (Finding 5): - Added maxNumLeaves (4096) and maxNumTrees (10000) constants. - finalizeTree rejects num_leaves <= 0 and num_leaves > maxNumLeaves BEFORE allocating SoA arrays. Closes a crafted-model-file DoS. - runTrees threads a tree counter and rejects when the parsed count would exceed maxNumTrees. - WAF/Rule.hs (Finding 6): - CompiledRegex changed from newtype to data with an extra !ByteString field carrying the original pattern. - Eq instance now compares by stored pattern bytes; reflexivity holds (x == x is True). Show instance now reveals the pattern for debugging. - test/Spec.hs: - +2 WAF tests verifying Eq CompiledRegex reflexivity and pattern-distinguishing. - +2 ML.Loader tests verifying num_leaves bound rejection (above maxNumLeaves and at zero). 358 total examples passing, 0 failures, 0 GHC warnings on touched modules. Audit findings 7-32 (MAJOR systemic + remaining MAJOR + MINOR) are deferred to subsequent passes per the audit plan. --- .../haskell-reverse-proxy/app/Main.hs | 20 +- .../src/Aenebris/Connection.hs | 48 ++-- .../src/Aenebris/ML/Loader.hs | 46 +++- .../src/Aenebris/Proxy.hs | 74 ++++-- .../haskell-reverse-proxy/src/Aenebris/TLS.hs | 206 +++++++------- .../src/Aenebris/Tunnel.hs | 251 +++++++++++++----- .../src/Aenebris/WAF/Rule.hs | 15 +- .../haskell-reverse-proxy/test/Spec.hs | 20 ++ 8 files changed, 446 insertions(+), 234 deletions(-) diff --git a/PROJECTS/advanced/haskell-reverse-proxy/app/Main.hs b/PROJECTS/advanced/haskell-reverse-proxy/app/Main.hs index 7ffd0af1..62d2ca7e 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/app/Main.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/app/Main.hs @@ -3,8 +3,18 @@ module Main (main) where import Aenebris.Config +import Aenebris.Connection + ( defaultTimeoutConfig + , microsPerSecond + , tcUpstreamReadSeconds + ) import Aenebris.Proxy -import Network.HTTP.Client (newManager, defaultManagerSettings) +import Network.HTTP.Client + ( ManagerSettings(..) + , defaultManagerSettings + , newManager + , responseTimeoutMicro + ) import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) @@ -37,8 +47,12 @@ main = do Right () -> do putStrLn "Configuration loaded and validated successfully" - -- Create HTTP client manager with connection pooling - manager <- newManager defaultManagerSettings + let upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig + * microsPerSecond + managerSettings = defaultManagerSettings + { managerResponseTimeout = responseTimeoutMicro upstreamMicros + } + manager <- newManager managerSettings -- Initialize proxy state (load balancers + health checkers) proxyState <- initProxyState config manager diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Connection.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Connection.hs index 30f0fee6..319c9bf7 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Connection.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Connection.hs @@ -1,3 +1,8 @@ +{- +©AngelaMos | 2026 +Connection.hs +-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -10,14 +15,14 @@ module Aenebris.Connection , isWebSocketUpgrade , isStreamingResponse , getTimeout + , microsPerSecond + , httpOkStatusCode ) where import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import Data.Maybe (isJust, fromMaybe) +import Data.Maybe (isJust) import Network.HTTP.Types (HeaderName, Status, statusCode) data ConnectionState @@ -35,23 +40,31 @@ data ConnectionType | ChunkedStream deriving (Eq, Show) +microsPerSecond :: Int +microsPerSecond = 1_000_000 + +httpOkStatusCode :: Int +httpOkStatusCode = 200 + data TimeoutConfig = TimeoutConfig - { tcHttpIdle :: Int - , tcWebSocketTunnel :: Int - , tcStreamingResponse :: Int - , tcProxyPingInterval :: Int - , tcPongTimeout :: Int - , tcConnectTimeout :: Int + { tcHttpIdle :: !Int + , tcWebSocketTunnel :: !Int + , tcStreamingResponse :: !Int + , tcProxyPingInterval :: !Int + , tcPongTimeout :: !Int + , tcConnectTimeout :: !Int + , tcUpstreamReadSeconds :: !Int } defaultTimeoutConfig :: TimeoutConfig defaultTimeoutConfig = TimeoutConfig - { tcHttpIdle = 60 - , tcWebSocketTunnel = 3600 - , tcStreamingResponse = 3600 - , tcProxyPingInterval = 30 - , tcPongTimeout = 10 - , tcConnectTimeout = 5 + { tcHttpIdle = 60 + , tcWebSocketTunnel = 3600 + , tcStreamingResponse = 3600 + , tcProxyPingInterval = 30 + , tcPongTimeout = 10 + , tcConnectTimeout = 5 + , tcUpstreamReadSeconds = 30 } getTimeout :: TimeoutConfig -> ConnectionState -> Int @@ -96,4 +109,7 @@ isStreamingResponse status headers = hasContentLength = isJust (lookup "Content-Length" headers) - isUnknownLength = statusCode status == 200 && not hasContentLength && not hasTransferEncodingChunked + isUnknownLength = + statusCode status == httpOkStatusCode + && not hasContentLength + && not hasTransferEncodingChunked diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Loader.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Loader.hs index dc1c5497..4b802487 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Loader.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Loader.hs @@ -44,6 +44,12 @@ requiredNumClass = 1 requiredNumTreePerIteration :: Int requiredNumTreePerIteration = 1 +maxNumLeaves :: Int +maxNumLeaves = 4096 + +maxNumTrees :: Int +maxNumTrees = 10000 + postParseLineSentinel :: Int postParseLineSentinel = -1 @@ -355,18 +361,26 @@ requireField key mv = case mv of ("Missing required header key: " <> key)) runTrees :: [(Int, Text)] -> Either ParseError [Tree] -runTrees lns = case dropWhile (lineIsBlank . snd) lns of - [] -> Right [] - ((n, ln):rest) - | T.strip ln == endOfTreesMarker -> Right [] - | T.isPrefixOf baseTreeKeyPrefix (T.strip ln) -> do - let (block, after) = break (lineIsBlank . snd) rest - tree <- parseTreeBlock block - more <- runTrees after - Right (tree : more) - | otherwise -> Left - (ParseError n treeKey - ("Expected 'Tree=N' or 'end of trees', got: " <> ln)) +runTrees = goTrees 0 + where + goTrees :: Int -> [(Int, Text)] -> Either ParseError [Tree] + goTrees treeCount lns + | treeCount > maxNumTrees = Left + (ParseError postParseLineSentinel treeKey + ("Tree count exceeds maxNumTrees " + <> T.pack (show maxNumTrees))) + | otherwise = case dropWhile (lineIsBlank . snd) lns of + [] -> Right [] + ((n, ln):rest) + | T.strip ln == endOfTreesMarker -> Right [] + | T.isPrefixOf baseTreeKeyPrefix (T.strip ln) -> do + let (block, after) = break (lineIsBlank . snd) rest + tree <- parseTreeBlock block + more <- goTrees (treeCount + 1) after + Right (tree : more) + | otherwise -> Left + (ParseError n treeKey + ("Expected 'Tree=N' or 'end of trees', got: " <> ln)) parseTreeBlock :: [(Int, Text)] -> Either ParseError Tree parseTreeBlock block = do @@ -428,6 +442,14 @@ assignTreeField acc n key val finalizeTree :: TreeAcc -> Either ParseError Tree finalizeTree acc = do nL <- requireField keyNumLeaves (taNumLeaves acc) + unless (nL > 0) + (Left (ParseError postParseLineSentinel keyNumLeaves + ("num_leaves must be positive: " <> T.pack (show nL)))) + unless (nL <= maxNumLeaves) + (Left (ParseError postParseLineSentinel keyNumLeaves + ("num_leaves " <> T.pack (show nL) + <> " exceeds maxNumLeaves " + <> T.pack (show maxNumLeaves)))) nC <- requireField keyNumCat (taNumCat acc) leafValues <- requireField keyLeafValue (taLeafValue acc) unless (length leafValues == nL) diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Proxy.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Proxy.hs index cb148d83..c8e3aea6 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Proxy.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Proxy.hs @@ -13,6 +13,12 @@ module Aenebris.Proxy import Aenebris.Backend import Aenebris.Config import Aenebris.Connection + ( ConnectionType(..) + , defaultTimeoutConfig + , detectConnectionType + , microsPerSecond + , tcUpstreamReadSeconds + ) import Aenebris.HealthCheck import Aenebris.LoadBalancer import Aenebris.TLS @@ -93,7 +99,9 @@ import Network.Wai.Handler.Warp , setTimeout ) import Network.Wai.Handler.WarpTLS (runTLS) +import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) +import System.Timeout (timeout) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 @@ -215,7 +223,9 @@ startProxy ProxyState{..} = do putStrLn $ "Health checking enabled for all upstreams" case configListen psConfig of - [] -> error "No listen ports configured" + [] -> do + hPutStrLn stderr "ERROR: No listen ports configured" + exitFailure listenConfigs -> do case psRateLimiter of Just _ -> putStrLn "Rate limiting enabled" @@ -339,9 +349,9 @@ launchHTTPS port tlsConfig app = do tlsResult <- createTLSSettings certFile keyFile case tlsResult of Left err -> do - hPutStrLn stderr $ "ERROR: Failed to load TLS certificate" + hPutStrLn stderr "ERROR: Failed to load TLS certificate" hPutStrLn stderr $ " " ++ show err - error "TLS configuration error" + exitFailure Right tlsSettings -> do let warpSettings = defaultSettings & setPort port @@ -352,7 +362,9 @@ launchHTTPS port tlsConfig app = do putStrLn $ " └─ Strong cipher suites enforced" runTLS tlsSettings warpSettings app - _ -> error "TLS configuration error: cert and key required" + _ -> do + hPutStrLn stderr "ERROR: TLS configuration requires both cert and key" + exitFailure -- | Launch HTTPS server with SNI support (multiple certificates) launchHTTPSWithSNI :: Int -> TLSConfig -> Application -> IO () @@ -366,9 +378,9 @@ launchHTTPSWithSNI port tlsConfig app = do tlsResult <- createSNISettings domainList defaultCert defaultKey case tlsResult of Left err -> do - hPutStrLn stderr $ "ERROR: Failed to load SNI certificates" + hPutStrLn stderr "ERROR: Failed to load SNI certificates" hPutStrLn stderr $ " " ++ show err - error "SNI configuration error" + exitFailure Right tlsSettings -> do let warpSettings = defaultSettings & setPort port @@ -381,7 +393,10 @@ launchHTTPSWithSNI port tlsConfig app = do putStrLn $ " └─ Strong cipher suites enforced" runTLS tlsSettings warpSettings app - _ -> error "SNI configuration error: sni, default_cert, and default_key required" + _ -> do + hPutStrLn stderr + "ERROR: SNI requires sni, default_cert, and default_key" + exitFailure -- | Main proxy application (WAI) proxyApp :: Config -> Map Text LoadBalancer -> Manager -> Application @@ -525,25 +540,34 @@ forwardRequest manager clientReq backendHost respond = do , HTTP.requestBody = streamingBody } - withResponse backendReq manager $ \backendResponse -> do - let status = HTTP.responseStatus backendResponse - headers = HTTP.responseHeaders backendResponse - bodyReader = HTTP.responseBody backendResponse + let upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig + * microsPerSecond + mResult <- timeout upstreamMicros $ + withResponse backendReq manager $ \backendResponse -> do + let status = HTTP.responseStatus backendResponse + headers = HTTP.responseHeaders backendResponse + bodyReader = HTTP.responseBody backendResponse - if shouldStreamResponse headers - then do - hPutStrLn stderr "[STREAM] Streaming response detected" - respond $ responseStream status (filterResponseHeaders headers) $ \write flush -> do - let loop = do - chunk <- brRead bodyReader - unless (BS.null chunk) $ do - write (byteString chunk) - flush - loop - loop - else do - body <- readFullBody bodyReader - respond $ responseLBS status (filterResponseHeaders headers) body + if shouldStreamResponse headers + then do + hPutStrLn stderr "[STREAM] Streaming response detected" + respond $ responseStream status (filterResponseHeaders headers) $ \write flush -> do + let loop = do + chunk <- brRead bodyReader + unless (BS.null chunk) $ do + write (byteString chunk) + flush + loop + loop + else do + body <- readFullBody bodyReader + respond $ responseLBS status (filterResponseHeaders headers) body + case mResult of + Just rr -> return rr + Nothing -> respond $ responseLBS + status504 + [("Content-Type", "text/plain")] + "504 Gateway Timeout: upstream did not respond in time" shouldStreamResponse :: [(HeaderName, BS.ByteString)] -> Bool shouldStreamResponse headers = diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/TLS.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/TLS.hs index 4e7b7d91..512d776d 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/TLS.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/TLS.hs @@ -1,3 +1,7 @@ +{- +©AngelaMos | 2026 +TLS.hs +-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,23 +12,27 @@ module Aenebris.TLS , createSNISettings , validateCertificate , CertificateError(..) + , strongCipherSuites ) where -import qualified Data.ByteString as BS +import Control.Exception (SomeException, try) +import qualified Data.ByteString.Lazy as LBS +import Data.Default.Class (def) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Map.Strict as Map -import Network.Wai.Handler.WarpTLS -import qualified Network.TLS as TLS -import qualified Network.TLS.Extra.Cipher as Cipher -import Data.Default.Class (def) import Data.X509 (SignedCertificate) import Data.X509.File (readSignedObject) +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra.Cipher as Cipher +import Network.Wai.Handler.WarpTLS import System.Directory (doesFileExist) -import Control.Exception (try, SomeException) +import System.IO (hPutStrLn, stderr) + +httpsRequiredMessage :: LBS.ByteString +httpsRequiredMessage = "This server requires HTTPS" --- | Certificate loading errors data CertificateError = CertFileNotFound FilePath | KeyFileNotFound FilePath @@ -32,130 +40,128 @@ data CertificateError | InvalidKey FilePath String deriving (Show, Eq) --- | Create TLS settings for a single certificate (non-SNI) -createTLSSettings :: FilePath -> FilePath -> IO (Either CertificateError TLSSettings) +createTLSSettings + :: FilePath + -> FilePath + -> IO (Either CertificateError TLSSettings) createTLSSettings certFile keyFile = do - -- Validate files exist certExists <- doesFileExist certFile - keyExists <- doesFileExist keyFile - + keyExists <- doesFileExist keyFile if not certExists - then return $ Left (CertFileNotFound certFile) + then pure (Left (CertFileNotFound certFile)) else if not keyExists - then return $ Left (KeyFileNotFound keyFile) + then pure (Left (KeyFileNotFound keyFile)) else do - -- Try to load the credential to validate it result <- try $ TLS.credentialLoadX509 certFile keyFile case result of Left (err :: SomeException) -> - return $ Left (InvalidCertificate certFile (show err)) - + pure (Left (InvalidCertificate certFile (show err))) Right (Left err) -> - return $ Left (InvalidCertificate certFile err) + pure (Left (InvalidCertificate certFile err)) + Right (Right _) -> + pure (Right (configureTLS certFile keyFile)) - Right (Right _credential) -> do - -- Create TLS settings with strong security - let tlsConfig = (tlsSettings certFile keyFile) - { tlsAllowedVersions = [TLS.TLS13, TLS.TLS12] - , tlsCiphers = strongCipherSuites - , onInsecure = DenyInsecure "This server requires HTTPS" - } +configureTLS :: FilePath -> FilePath -> TLSSettings +configureTLS certFile keyFile = (tlsSettings certFile keyFile) + { tlsAllowedVersions = [TLS.TLS13, TLS.TLS12] + , tlsCiphers = strongCipherSuites + , onInsecure = DenyInsecure httpsRequiredMessage + } - return $ Right tlsConfig - --- | Create TLS settings with SNI support for multiple domains -createSNISettings :: [(Text, FilePath, FilePath)] -> FilePath -> FilePath -> IO (Either CertificateError TLSSettings) +createSNISettings + :: [(Text, FilePath, FilePath)] + -> FilePath + -> FilePath + -> IO (Either CertificateError TLSSettings) createSNISettings domains defaultCert defaultKey = do - -- Validate default certificate - defaultExists <- doesFileExist defaultCert - defaultKeyExists <- doesFileExist defaultKey - - if not defaultExists - then return $ Left (CertFileNotFound defaultCert) - else if not defaultKeyExists - then return $ Left (KeyFileNotFound defaultKey) + defaultCertOk <- doesFileExist defaultCert + defaultKeyOk <- doesFileExist defaultKey + if not defaultCertOk + then pure (Left (CertFileNotFound defaultCert)) + else if not defaultKeyOk + then pure (Left (KeyFileNotFound defaultKey)) else do - -- Validate all domain certificates exist - validationResults <- mapM validateDomainCert domains - case sequence validationResults of - Left err -> return $ Left err - Right _ -> do - -- Create SNI-enabled TLS settings using the default cert first - let baseTLS = tlsSettings defaultCert defaultKey - tlsConfig = baseTLS - { tlsAllowedVersions = [TLS.TLS13, TLS.TLS12] - , tlsCiphers = strongCipherSuites - , onInsecure = DenyInsecure "This server requires HTTPS" - , tlsServerHooks = def - { TLS.onServerNameIndication = \mHostname -> case mHostname of - Nothing -> loadCredentials defaultCert defaultKey - Just hostname -> sniCallback domains defaultCert defaultKey hostname - } - } + validations <- mapM validateDomainCert domains + case sequence validations of + Left err -> pure (Left err) + Right _ -> pure (Right (configureSNI domains defaultCert defaultKey)) - return $ Right tlsConfig - where - validateDomainCert :: (Text, FilePath, FilePath) -> IO (Either CertificateError ()) - validateDomainCert (domain, certFile, keyFile) = do - certExists <- doesFileExist certFile - keyExists <- doesFileExist keyFile +configureSNI + :: [(Text, FilePath, FilePath)] + -> FilePath + -> FilePath + -> TLSSettings +configureSNI domains defaultCert defaultKey = + let baseTLS = tlsSettings defaultCert defaultKey + in baseTLS + { tlsAllowedVersions = [TLS.TLS13, TLS.TLS12] + , tlsCiphers = strongCipherSuites + , onInsecure = DenyInsecure httpsRequiredMessage + , tlsServerHooks = def + { TLS.onServerNameIndication = \mHostname -> case mHostname of + Nothing -> credentialsOrDefault defaultCert defaultKey + Just hostname -> + sniCallback domains defaultCert defaultKey hostname + } + } - if not certExists - then return $ Left (CertFileNotFound certFile) - else if not keyExists - then return $ Left (KeyFileNotFound keyFile) - else return $ Right () +validateDomainCert + :: (Text, FilePath, FilePath) -> IO (Either CertificateError ()) +validateDomainCert (_domain, certFile, keyFile) = do + certExists <- doesFileExist certFile + keyExists <- doesFileExist keyFile + if not certExists + then pure (Left (CertFileNotFound certFile)) + else if not keyExists + then pure (Left (KeyFileNotFound keyFile)) + else pure (Right ()) --- | SNI callback function - returns credentials based on hostname -sniCallback :: [(Text, FilePath, FilePath)] -> FilePath -> FilePath -> String -> IO TLS.Credentials -sniCallback domains defaultCert defaultKey hostname = do - let hostnameText = T.pack hostname - -- Look up domain in map +sniCallback + :: [(Text, FilePath, FilePath)] + -> FilePath + -> FilePath + -> String + -> IO TLS.Credentials +sniCallback domains defaultCert defaultKey hostname = + let domainMap :: Map Text (FilePath, FilePath) domainMap = Map.fromList [(d, (c, k)) | (d, c, k) <- domains] + in case Map.lookup (T.pack hostname) domainMap of + Nothing -> credentialsOrDefault defaultCert defaultKey + Just (certFile, keyFile) -> + credentialsOrDefault certFile keyFile - case Map.lookup hostnameText domainMap of - Nothing -> do - -- No match, use default certificate - loadCredentials defaultCert defaultKey - - Just (certFile, keyFile) -> do - -- Found matching domain, load its certificate - loadCredentials certFile keyFile - --- | Load TLS credentials from certificate and key files -loadCredentials :: FilePath -> FilePath -> IO TLS.Credentials -loadCredentials certFile keyFile = do +credentialsOrDefault :: FilePath -> FilePath -> IO TLS.Credentials +credentialsOrDefault certFile keyFile = do result <- TLS.credentialLoadX509 certFile keyFile case result of - Left err -> - error $ "Failed to load certificate: " ++ err + Left err -> do + hPutStrLn stderr $ + "TLS: failed to load credential at " + <> certFile <> " (" <> err <> "); SNI handler returns empty credentials" + pure (TLS.Credentials []) Right credential -> - return $ TLS.Credentials [credential] + pure (TLS.Credentials [credential]) --- | Validate a certificate file (check if it's readable and valid) -validateCertificate :: FilePath -> IO (Either CertificateError [SignedCertificate]) +validateCertificate + :: FilePath -> IO (Either CertificateError [SignedCertificate]) validateCertificate certFile = do exists <- doesFileExist certFile if not exists - then return $ Left (CertFileNotFound certFile) + then pure (Left (CertFileNotFound certFile)) else do result <- try $ readSignedObject certFile case result of Left (err :: SomeException) -> - return $ Left (InvalidCertificate certFile (show err)) + pure (Left (InvalidCertificate certFile (show err))) Right certs -> - return $ Right certs + pure (Right certs) --- | Strong cipher suites for production (TLS 1.2 + TLS 1.3) strongCipherSuites :: [TLS.Cipher] strongCipherSuites = - -- TLS 1.3 cipher suites (preferred) - [ Cipher.cipher_TLS13_AES128GCM_SHA256 - , Cipher.cipher_TLS13_AES256GCM_SHA384 - , Cipher.cipher_TLS13_CHACHA20POLY1305_SHA256 - ] ++ - -- TLS 1.2 cipher suites (fallback, only ECDHE + AEAD) - [ Cipher.cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 + [ Cipher.cipher13_AES_128_GCM_SHA256 + , Cipher.cipher13_AES_256_GCM_SHA384 + , Cipher.cipher13_CHACHA20_POLY1305_SHA256 + , Cipher.cipher_ECDHE_RSA_WITH_AES_128_GCM_SHA256 , Cipher.cipher_ECDHE_RSA_WITH_AES_256_GCM_SHA384 , Cipher.cipher_ECDHE_RSA_WITH_CHACHA20_POLY1305_SHA256 , Cipher.cipher_ECDHE_ECDSA_WITH_AES_128_GCM_SHA256 diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Tunnel.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Tunnel.hs index 8d81e404..99555c19 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Tunnel.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Tunnel.hs @@ -1,27 +1,95 @@ +{- +©AngelaMos | 2026 +Tunnel.hs +-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} module Aenebris.Tunnel - ( tunnelWebSocket + ( ConnectError(..) + , connectToBackend + , parseHostPort + , parseUpgradeStatus + , tunnelWebSocket , streamResponse , bidirectionalCopy ) where import Control.Concurrent.Async (race_) -import Control.Exception (SomeException, try, bracket) +import Control.Exception + ( SomeException + , bracketOnError + , finally + , try + ) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS8 import Data.CaseInsensitive (original) import Data.Text (Text) import qualified Data.Text as T -import Network.HTTP.Types (HeaderName) import Network.Socket (Socket) import qualified Network.Socket as Socket import qualified Network.Socket.ByteString as SocketBS import Network.Wai + ( Request + , rawPathInfo + , rawQueryString + , requestHeaders + , requestMethod + ) import System.IO (hPutStrLn, stderr) +import System.Timeout (timeout) + +defaultBackendPort :: Int +defaultBackendPort = 80 + +upgradeRecvChunkBytes :: Int +upgradeRecvChunkBytes = 4_096 + +maxUpgradeHeaderBytes :: Int +maxUpgradeHeaderBytes = 16_384 + +tunnelRecvChunkBytes :: Int +tunnelRecvChunkBytes = 65_536 + +connectTimeoutSeconds :: Int +connectTimeoutSeconds = 5 + +upgradeIdleSeconds :: Int +upgradeIdleSeconds = 30 + +microsPerSecond :: Int +microsPerSecond = 1_000_000 + +upgradeStatusSwitching :: Int +upgradeStatusSwitching = 101 + +badGatewayResponseLine :: ByteString +badGatewayResponseLine = "HTTP/1.1 502 Bad Gateway\r\n\r\n" + +upgradeTerminator :: ByteString +upgradeTerminator = "\r\n\r\n" + +httpHeaderLineEnd :: ByteString +httpHeaderLineEnd = "\r\n" + +httpVersionAndCrlf :: ByteString +httpVersionAndCrlf = " HTTP/1.1\r\n" + +httpFieldSeparator :: ByteString +httpFieldSeparator = ": " + +requestPathSeparator :: ByteString +requestPathSeparator = " " + +data ConnectError + = ResolutionFailed !String !Int + | ConnectTimeout !String !Int + | ConnectFailed !String !Int !String + deriving (Eq, Show) tunnelWebSocket :: Request @@ -31,39 +99,62 @@ tunnelWebSocket -> IO () tunnelWebSocket clientReq backendHost clientSend clientRecv = do hPutStrLn stderr $ "[WS] Initiating tunnel to " ++ T.unpack backendHost - - result <- try $ do - let (host, port) = parseHostPort backendHost - - bracket - (connectToBackend host port) - Socket.close - $ \backendSocket -> do - sendUpgradeRequest backendSocket clientReq - upgradeResponse <- receiveUpgradeResponse backendSocket - - case parseUpgradeStatus upgradeResponse of - Just 101 -> do - hPutStrLn stderr "[WS] Backend accepted upgrade (101)" - clientSend upgradeResponse - bidirectionalCopy clientRecv clientSend - (SocketBS.recv backendSocket 65536) - (SocketBS.sendAll backendSocket) - - Just code -> do - hPutStrLn stderr $ "[WS] Backend rejected upgrade: " ++ show code - clientSend upgradeResponse - - Nothing -> do - hPutStrLn stderr "[WS] Invalid upgrade response" - clientSend "HTTP/1.1 502 Bad Gateway\r\n\r\n" - - case result of + let (host, port) = parseHostPort backendHost + outcome <- try $ do + eSock <- connectToBackend host port + case eSock of + Left err -> do + hPutStrLn stderr $ "[WS] Connection failed: " ++ show err + clientSend badGatewayResponseLine + Right sock -> + runUpgrade clientReq clientSend clientRecv sock + `finally` Socket.close sock + case outcome of Left (e :: SomeException) -> hPutStrLn stderr $ "[WS] Tunnel error: " ++ show e Right () -> hPutStrLn stderr "[WS] Tunnel closed" +runUpgrade + :: Request + -> (ByteString -> IO ()) + -> IO ByteString + -> Socket + -> IO () +runUpgrade clientReq clientSend clientRecv sock = do + sendUpgradeRequest sock clientReq + mResponse <- timeout + (upgradeIdleSeconds * microsPerSecond) + (receiveUpgradeResponse sock) + case mResponse of + Nothing -> do + hPutStrLn stderr "[WS] Upgrade response timed out" + clientSend badGatewayResponseLine + Just upgradeResponse -> + dispatchUpgrade sock clientSend clientRecv upgradeResponse + +dispatchUpgrade + :: Socket + -> (ByteString -> IO ()) + -> IO ByteString + -> ByteString + -> IO () +dispatchUpgrade sock clientSend clientRecv upgradeResponse = + case parseUpgradeStatus upgradeResponse of + Just code | code == upgradeStatusSwitching -> do + hPutStrLn stderr "[WS] Backend accepted upgrade (101)" + clientSend upgradeResponse + bidirectionalCopy + clientRecv clientSend + (SocketBS.recv sock tunnelRecvChunkBytes) + (SocketBS.sendAll sock) + Just code -> do + hPutStrLn stderr $ "[WS] Backend rejected upgrade: " ++ show code + clientSend upgradeResponse + Nothing -> do + hPutStrLn stderr "[WS] Invalid upgrade response" + clientSend badGatewayResponseLine + bidirectionalCopy :: IO ByteString -> (ByteString -> IO ()) @@ -72,11 +163,9 @@ bidirectionalCopy -> IO () bidirectionalCopy clientRecv clientSend backendRecv backendSend = do hPutStrLn stderr "[TUNNEL] Starting bidirectional copy" - race_ (copyLoop "client->backend" clientRecv backendSend) (copyLoop "backend->client" backendRecv clientSend) - hPutStrLn stderr "[TUNNEL] Bidirectional copy ended" copyLoop :: String -> IO ByteString -> (ByteString -> IO ()) -> IO () @@ -112,56 +201,74 @@ parseHostPort hostPort = [host, portStr] -> case reads (T.unpack portStr) of [(port, "")] -> (T.unpack host, port) - _ -> (T.unpack host, 80) - [host] -> (T.unpack host, 80) - _ -> (T.unpack hostPort, 80) + _ -> (T.unpack host, defaultBackendPort) + [host] -> (T.unpack host, defaultBackendPort) + _ -> (T.unpack hostPort, defaultBackendPort) -connectToBackend :: String -> Int -> IO Socket +connectToBackend :: String -> Int -> IO (Either ConnectError Socket) connectToBackend host port = do - addrInfos <- Socket.getAddrInfo + resolution <- try $ Socket.getAddrInfo (Just Socket.defaultHints { Socket.addrSocketType = Socket.Stream }) (Just host) - (Just $ show port) + (Just (show port)) + case resolution of + Left (_ :: SomeException) -> pure (Left (ResolutionFailed host port)) + Right [] -> pure (Left (ResolutionFailed host port)) + Right (addr : _) -> attemptConnect host port addr - case addrInfos of - [] -> error $ "Cannot resolve: " ++ host ++ ":" ++ show port - (addr:_) -> do - sock <- Socket.socket - (Socket.addrFamily addr) - Socket.Stream - Socket.defaultProtocol - Socket.connect sock (Socket.addrAddress addr) - return sock +attemptConnect + :: String -> Int -> Socket.AddrInfo -> IO (Either ConnectError Socket) +attemptConnect host port addr = + bracketOnError + (Socket.socket + (Socket.addrFamily addr) + Socket.Stream + Socket.defaultProtocol) + Socket.close + $ \sock -> do + mConnect <- timeout + (connectTimeoutSeconds * microsPerSecond) + (try (Socket.connect sock (Socket.addrAddress addr))) + case mConnect of + Nothing -> do + Socket.close sock + pure (Left (ConnectTimeout host port)) + Just (Left (e :: SomeException)) -> do + Socket.close sock + pure (Left (ConnectFailed host port (show e))) + Just (Right ()) -> + pure (Right sock) sendUpgradeRequest :: Socket -> Request -> IO () -sendUpgradeRequest sock req = do - let method = requestMethod req - path = rawPathInfo req <> rawQueryString req - headers = requestHeaders req - - requestLine = method <> " " <> path <> " HTTP/1.1\r\n" +sendUpgradeRequest sock req = + let method = requestMethod req + path = rawPathInfo req <> rawQueryString req + headers = requestHeaders req + requestLine = method <> requestPathSeparator <> path <> httpVersionAndCrlf headerLines = BS.concat - [ original name <> ": " <> value <> "\r\n" + [ original name <> httpFieldSeparator <> value <> httpHeaderLineEnd | (name, value) <- headers ] - fullRequest = requestLine <> headerLines <> "\r\n" - - SocketBS.sendAll sock fullRequest + fullRequest = requestLine <> headerLines <> httpHeaderLineEnd + in SocketBS.sendAll sock fullRequest receiveUpgradeResponse :: Socket -> IO ByteString -receiveUpgradeResponse sock = do - chunk <- SocketBS.recv sock 4096 - if "\r\n\r\n" `BS.isInfixOf` chunk - then return chunk - else do - rest <- receiveUpgradeResponse sock - return $ chunk <> rest +receiveUpgradeResponse sock = go BS.empty + where + go !acc + | upgradeTerminator `BS.isInfixOf` acc = pure acc + | BS.length acc >= maxUpgradeHeaderBytes = pure acc + | otherwise = do + chunk <- SocketBS.recv sock upgradeRecvChunkBytes + if BS.null chunk + then pure acc + else go (acc <> chunk) parseUpgradeStatus :: ByteString -> Maybe Int -parseUpgradeStatus response = - case BS8.words (head $ BS8.lines response) of - (_:codeBS:_) -> - case reads (BS8.unpack codeBS) of - [(code, "")] -> Just code - _ -> Nothing +parseUpgradeStatus response = case BS8.lines response of + [] -> Nothing + (firstLine : _) -> case BS8.words firstLine of + (_ : codeBS : _) -> case reads (BS8.unpack codeBS) of + [(code, "")] -> Just code + _ -> Nothing _ -> Nothing diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Rule.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Rule.hs index 5ea9854d..11d3e56b 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Rule.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Rule.hs @@ -72,13 +72,16 @@ data Target | TargetUserAgent deriving (Eq, Show) -newtype CompiledRegex = CompiledRegex { unCompiledRegex :: Regex } +data CompiledRegex = CompiledRegex + { unCompiledRegex :: !Regex + , compiledRegexPattern :: !ByteString + } instance Show CompiledRegex where - show _ = "" + show r = "" instance Eq CompiledRegex where - _ == _ = False + a == b = compiledRegexPattern a == compiledRegexPattern b data Operator = OpRegex !CompiledRegex @@ -115,13 +118,13 @@ compileRegex :: ByteString -> Either String CompiledRegex compileRegex pat = case compile compOpts execOpts pat of Left err -> Left err - Right r -> Right (CompiledRegex r) + Right r -> Right (CompiledRegex r pat) where compOpts = TDFA.defaultCompOpt { TDFA.caseSensitive = False } execOpts = TDFA.defaultExecOpt runRegex :: CompiledRegex -> ByteString -> Bool -runRegex (CompiledRegex r) input = - case execute r input of +runRegex cr input = + case execute (unCompiledRegex cr) input of Right (Just _) -> True _ -> False diff --git a/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs b/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs index c9f1ca5e..d0914406 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs @@ -817,6 +817,16 @@ wafSpec = describe "WAF" $ do severityScore SevWarning `shouldBe` 3 severityScore SevNotice `shouldBe` 2 + it "Eq CompiledRegex is reflexive (x == x)" $ + case compileRegex "abc" of + Right r -> r `shouldBe` r + Left err -> expectationFailure err + + it "Eq CompiledRegex distinguishes different patterns" $ + case (compileRegex "abc", compileRegex "def") of + (Right r1, Right r2) -> (r1 == r2) `shouldBe` False + _ -> expectationFailure "expected both to compile" + it "default ruleset includes rules" $ length (rsRules defaultRuleSet) `shouldSatisfy` (> 0) @@ -2074,6 +2084,16 @@ mlLoaderSpec = describe "ML.Loader" $ do (T.replace "leaf_value=0.5\n" "leaf_value=0.5\nbogus=1\n" mlLoaderModel)) `shouldSatisfy` isLeft + it "rejects num_leaves above maxNumLeaves" $ + parseEnsemble + (TE.encodeUtf8 (T.replace "num_leaves=1" "num_leaves=999999" mlLoaderModel)) + `shouldSatisfy` parseFailsAt "num_leaves" + + it "rejects num_leaves of 0" $ + parseEnsemble + (TE.encodeUtf8 (T.replace "num_leaves=1" "num_leaves=0" mlLoaderModel)) + `shouldSatisfy` parseFailsAt "num_leaves" + describe "feature_names containing '='" $ it "accepts feature_names with '=' in a name" $ parseEnsemble From 998b5268e070f158021e268482be50081337a956 Mon Sep 17 00:00:00 2001 From: CarterPerez-dev Date: Wed, 29 Apr 2026 02:12:00 -0400 Subject: [PATCH 3/5] fix: close audit-pass-1 MAJOR systemic findings (Findings 7-13) Brings the older pre-ML modules up to the same standard as the newer ML pipeline. Closes Findings 7 (file headers), 8 (inline comments), 9 (NIH reimplementations), 11 (selectWeightedRR partial function + O(n^2)), 12 (weak LoadBalancer tests), 13 (placeholder Backend / ConnLimit tests), and 32 (locally-redefined HTTP status constants). Module rewrites with new file header + zero inline comments: - src/Aenebris/Proxy.hs - src/Aenebris/LoadBalancer.hs - src/Aenebris/HealthCheck.hs - src/Aenebris/Middleware/Security.hs - src/Aenebris/Middleware/Redirect.hs - src/Aenebris/Config.hs - src/Aenebris/Backend.hs - app/Main.hs Algorithmic + structural fixes: - LoadBalancer.selectWeightedRR no longer uses partial (!!) and a separate find/maximum/index pass; replaced with a single STM fold that tags each backend with its current weight and picks via Data.List.maximumBy + Data.Ord.comparing. O(n) instead of O(n^2), no Maybe fallback. - Proxy.proxyApp deduplicates the regular-HTTP code path that was copy-pasted across the WebSocket and `_` connection-type branches (Finding 16). Single forwardRegular helper called from both. - Proxy.logRequest removed; per-request stdout logging was inconsistent with the stderr error pattern used elsewhere and a perf hazard at scale (Finding 17). Defer real structured logging to Phase 4 per docs/status/MASTER_PLAN_2026.md. - Backend.recordFailure now increments rbTotalFailures uniformly across all states (Finding 22), not just Unhealthy. - Backend.Show instance now includes weight (Finding 21). - Connection.hs gains microsPerSecond and httpOkStatusCode named constants. tcUpstreamReadSeconds added to TimeoutConfig. - HealthCheck uses the shared microsPerSecond constant instead of inline 1000000 (Finding 18). Compares status against the named httpOkStatusCode constant. NIH reimplementations replaced with stdlib: - LoadBalancer: filterM, forM_ from Control.Monad; minimumBy, maximumBy from Data.List; comparing from Data.Ord. - Proxy: zipWithM from Control.Monad. - HealthCheck: zipWithM_ from Control.Monad. - Middleware.Security: catMaybes from Data.Maybe. - Config: nub from Data.List (replaces local nubText). - Fingerprint.JA4H, ML.Features: built-in lookup over [(CI ByteString, ByteString)] (CI ByteString already has Eq). - RateLimit, DDoS.ConnLimit: intercalate ":" from Data.List (replaces duplicated joinColons in two files). - Honeypot: status200, status404 from Network.HTTP.Types (drops local mkStatus duplications). - WAF.Engine: status403 from Network.HTTP.Types. Test strengthening (test/Spec.hs): - loadBalancerSpec: round-robin now asserts even distribution ([3,3,3] across 3 backends in 9 rounds); weighted RR asserts the 4-weight backend wins >= 35 of 50 picks; least-connections asserts the lower-count backend is selected after manually bumping the other to 5 active connections. - backendSpec: "tolerates repeated failures" replaced with a real state-transition test ('Healthy after 1 failure, Healthy after 2, Unhealthy after 3'). 'records successes without crashing' replaced with assertion that recordSuccess on Healthy resets rbConsecutiveFailures to 0. - connLimitSpec: 'release decrements counter' now reads currentCount before and after release to assert the count actually went 1 -> 0. Build clean, 358 examples passing, 0 failures, 0 GHC warnings on any touched module. Audit findings 14, 15, 18 (residual MAJOR) and 19-31 (MINOR) deferred to subsequent passes. --- .../haskell-reverse-proxy/app/Main.hs | 49 +- .../src/Aenebris/Backend.hs | 111 ++-- .../src/Aenebris/Config.hs | 268 ++++---- .../src/Aenebris/DDoS/ConnLimit.hs | 8 +- .../src/Aenebris/Fingerprint/JA4H.hs | 7 +- .../src/Aenebris/HealthCheck.hs | 79 +-- .../src/Aenebris/Honeypot.hs | 8 +- .../src/Aenebris/LoadBalancer.hs | 136 ++-- .../src/Aenebris/ML/Features.hs | 27 +- .../src/Aenebris/Middleware/Redirect.hs | 56 +- .../src/Aenebris/Middleware/Security.hs | 154 ++--- .../src/Aenebris/Proxy.hs | 616 +++++++++--------- .../src/Aenebris/RateLimit.hs | 8 +- .../src/Aenebris/WAF/Engine.hs | 5 +- .../haskell-reverse-proxy/test/Spec.hs | 77 ++- 15 files changed, 780 insertions(+), 829 deletions(-) diff --git a/PROJECTS/advanced/haskell-reverse-proxy/app/Main.hs b/PROJECTS/advanced/haskell-reverse-proxy/app/Main.hs index 62d2ca7e..d557f60e 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/app/Main.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/app/Main.hs @@ -1,3 +1,7 @@ +{- +©AngelaMos | 2026 +Main.hs +-} {-# LANGUAGE OverloadedStrings #-} module Main (main) where @@ -19,43 +23,38 @@ import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) +defaultConfigPath :: FilePath +defaultConfigPath = "config.yaml" + main :: IO () main = do args <- getArgs - - -- Get config file path from args or use default let configPath = case args of (path:_) -> path - [] -> "config.yaml" + [] -> defaultConfigPath putStrLn $ "Loading configuration from: " ++ configPath result <- loadConfig configPath case result of Left err -> do - hPutStrLn stderr $ "ERROR: Failed to load configuration" + hPutStrLn stderr "ERROR: Failed to load configuration" hPutStrLn stderr err exitFailure - Right config -> do - case validateConfig config of - Left err -> do - hPutStrLn stderr $ "ERROR: Invalid configuration" - hPutStrLn stderr err - exitFailure + Right config -> case validateConfig config of + Left err -> do + hPutStrLn stderr "ERROR: Invalid configuration" + hPutStrLn stderr err + exitFailure - Right () -> do - putStrLn "Configuration loaded and validated successfully" - - let upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig - * microsPerSecond - managerSettings = defaultManagerSettings - { managerResponseTimeout = responseTimeoutMicro upstreamMicros - } - manager <- newManager managerSettings - - -- Initialize proxy state (load balancers + health checkers) - proxyState <- initProxyState config manager - - -- Start the proxy - startProxy proxyState + Right () -> do + putStrLn "Configuration loaded and validated successfully" + let upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig + * microsPerSecond + managerSettings = defaultManagerSettings + { managerResponseTimeout = responseTimeoutMicro upstreamMicros + } + manager <- newManager managerSettings + proxyState <- initProxyState config manager + startProxy proxyState diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Backend.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Backend.hs index d77062a8..127aaa5c 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Backend.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Backend.hs @@ -1,3 +1,7 @@ +{- +©AngelaMos | 2026 +Backend.hs +-} {-# LANGUAGE RecordWildCards #-} module Aenebris.Backend @@ -22,126 +26,125 @@ import Control.Monad (when) import Data.Text (Text) import Data.Time.Clock (UTCTime) +initialActiveConnections :: Int +initialActiveConnections = 0 + +initialCurrentWeight :: Int +initialCurrentWeight = 0 + +initialFailureCount :: Int +initialFailureCount = 0 + +initialSuccessCount :: Int +initialSuccessCount = 0 + +initialMetricCount :: Int +initialMetricCount = 0 + data BackendState = Healthy | Unhealthy | Recovering deriving (Eq, Show) --- | Runtime backend state wrapping config Server data RuntimeBackend = RuntimeBackend - { rbServerId :: Int -- Unique identifier - , rbHost :: Text - , rbWeight :: Int - -- Runtime state (STM) - , rbActiveConnections :: TVar Int - , rbCurrentWeight :: TVar Int - , rbHealthState :: TVar BackendState - , rbConsecutiveFailures :: TVar Int - , rbConsecutiveSuccesses :: TVar Int - , rbLastHealthCheck :: TVar (Maybe UTCTime) - , rbTotalRequests :: TVar Int -- For metrics - , rbTotalFailures :: TVar Int -- For metrics + { rbServerId :: !Int + , rbHost :: !Text + , rbWeight :: !Int + , rbActiveConnections :: !(TVar Int) + , rbCurrentWeight :: !(TVar Int) + , rbHealthState :: !(TVar BackendState) + , rbConsecutiveFailures :: !(TVar Int) + , rbConsecutiveSuccesses :: !(TVar Int) + , rbLastHealthCheck :: !(TVar (Maybe UTCTime)) + , rbTotalRequests :: !(TVar Int) + , rbTotalFailures :: !(TVar Int) } instance Show RuntimeBackend where - show rb = "RuntimeBackend {id=" ++ show (rbServerId rb) ++ - ", host=" ++ show (rbHost rb) ++ "}" + show rb = "RuntimeBackend {id=" + ++ show (rbServerId rb) + ++ ", host=" + ++ show (rbHost rb) + ++ ", weight=" + ++ show (rbWeight rb) + ++ "}" instance Eq RuntimeBackend where rb1 == rb2 = rbServerId rb1 == rbServerId rb2 --- | Runtime backend from config Server createRuntimeBackend :: Int -> Server -> IO RuntimeBackend -createRuntimeBackend serverId Server{..} = do - atomically $ RuntimeBackend serverId serverHost serverWeight - <$> newTVar 0 -- activeConnections - <*> newTVar 0 -- currentWeight (for smooth WRR) - <*> newTVar Healthy -- healthState - <*> newTVar 0 -- consecutiveFailures - <*> newTVar 0 -- consecutiveSuccesses - <*> newTVar Nothing -- lastHealthCheck - <*> newTVar 0 -- totalRequests - <*> newTVar 0 -- totalFailures +createRuntimeBackend serverId Server{..} = atomically $ + RuntimeBackend serverId serverHost serverWeight + <$> newTVar initialActiveConnections + <*> newTVar initialCurrentWeight + <*> newTVar Healthy + <*> newTVar initialFailureCount + <*> newTVar initialSuccessCount + <*> newTVar Nothing + <*> newTVar initialMetricCount + <*> newTVar initialMetricCount --- | Check if backend is healthy isHealthy :: RuntimeBackend -> STM Bool isHealthy rb = (== Healthy) <$> readTVar (rbHealthState rb) --- | Track a connection (increment on start, decrement on end) trackConnection :: RuntimeBackend -> IO a -> IO a trackConnection rb action = bracket_ (atomically $ do - modifyTVar' (rbActiveConnections rb) (+1) - modifyTVar' (rbTotalRequests rb) (+1)) + modifyTVar' (rbActiveConnections rb) (+ 1) + modifyTVar' (rbTotalRequests rb) (+ 1)) (atomically $ modifyTVar' (rbActiveConnections rb) (subtract 1)) action --- | Get current connection count getConnectionCount :: RuntimeBackend -> STM Int getConnectionCount rb = readTVar (rbActiveConnections rb) --- | Get current weight (for smooth weighted RR) getCurrentWeight :: RuntimeBackend -> STM Int getCurrentWeight rb = readTVar (rbCurrentWeight rb) --- | State transition: mark as unhealthy transitionToUnhealthy :: RuntimeBackend -> STM () transitionToUnhealthy rb = do writeTVar (rbHealthState rb) Unhealthy - writeTVar (rbConsecutiveFailures rb) 0 - writeTVar (rbConsecutiveSuccesses rb) 0 + writeTVar (rbConsecutiveFailures rb) initialFailureCount + writeTVar (rbConsecutiveSuccesses rb) initialSuccessCount --- | State transition: start recovering transitionToRecovering :: RuntimeBackend -> STM () transitionToRecovering rb = do writeTVar (rbHealthState rb) Recovering writeTVar (rbConsecutiveSuccesses rb) 1 --- | State transition: mark as healthy transitionToHealthy :: RuntimeBackend -> STM () transitionToHealthy rb = do writeTVar (rbHealthState rb) Healthy - writeTVar (rbConsecutiveFailures rb) 0 - writeTVar (rbConsecutiveSuccesses rb) 0 + writeTVar (rbConsecutiveFailures rb) initialFailureCount + writeTVar (rbConsecutiveSuccesses rb) initialSuccessCount --- | Record a health check failure recordFailure :: RuntimeBackend -> Int -> STM () recordFailure rb maxFailures = do + modifyTVar' (rbTotalFailures rb) (+ 1) state <- readTVar (rbHealthState rb) failures <- readTVar (rbConsecutiveFailures rb) - case state of Healthy -> do let newFailures = failures + 1 writeTVar (rbConsecutiveFailures rb) newFailures when (newFailures >= maxFailures) $ transitionToUnhealthy rb - - Recovering -> do - -- Failed during recovery, back to unhealthy + Recovering -> transitionToUnhealthy rb - Unhealthy -> - -- Already unhealthy, just record it - modifyTVar' (rbTotalFailures rb) (+1) + pure () --- | Record a health check success recordSuccess :: RuntimeBackend -> Int -> STM () recordSuccess rb recoveryAttempts = do state <- readTVar (rbHealthState rb) successes <- readTVar (rbConsecutiveSuccesses rb) - case state of Healthy -> - -- Reset failure counter - writeTVar (rbConsecutiveFailures rb) 0 - + writeTVar (rbConsecutiveFailures rb) initialFailureCount Unhealthy -> - -- First success, transition to recovering transitionToRecovering rb - Recovering -> do let newSuccesses = successes + 1 writeTVar (rbConsecutiveSuccesses rb) newSuccesses diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Config.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Config.hs index c2876f13..4446a717 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Config.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Config.hs @@ -1,3 +1,7 @@ +{- +©AngelaMos | 2026 +Config.hs +-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} @@ -20,51 +24,63 @@ module Aenebris.Config import Aenebris.Honeypot (HoneypotConfigYaml) import Aenebris.Geo (GeoConfigYaml) -import Control.Monad (when, forM_) +import Control.Monad (forM_, when) import Data.Aeson +import Data.List (nub) import Data.Text (Text) import qualified Data.Text as T import Data.Yaml (decodeFileEither) import GHC.Generics --- | Main config structure +supportedConfigVersion :: Int +supportedConfigVersion = 1 + +minPort :: Int +minPort = 1 + +maxPort :: Int +maxPort = 65535 + +minServerWeight :: Int +minServerWeight = 1 + data Config = Config - { configVersion :: Int - , configListen :: [ListenConfig] - , configUpstreams :: [Upstream] - , configRoutes :: [Route] - , configRateLimit :: Maybe Text - , configDDoS :: Maybe DDoSConfig - , configHoneypot :: Maybe HoneypotConfigYaml - , configGeo :: Maybe GeoConfigYaml + { configVersion :: !Int + , configListen :: ![ListenConfig] + , configUpstreams :: ![Upstream] + , configRoutes :: ![Route] + , configRateLimit :: !(Maybe Text) + , configDDoS :: !(Maybe DDoSConfig) + , configHoneypot :: !(Maybe HoneypotConfigYaml) + , configGeo :: !(Maybe GeoConfigYaml) } deriving (Show, Eq, Generic) instance FromJSON Config where parseJSON = withObject "Config" $ \v -> Config - <$> v .: "version" - <*> v .: "listen" - <*> v .: "upstreams" - <*> v .: "routes" + <$> v .: "version" + <*> v .: "listen" + <*> v .: "upstreams" + <*> v .: "routes" <*> v .:? "rate_limit" <*> v .:? "ddos" <*> v .:? "honeypot" <*> v .:? "geo" data DDoSConfig = DDoSConfig - { ddosEarlyDataReject :: Bool - , ddosPerIPConnections :: Maybe Int - , ddosMemoryShedBytes :: Maybe Integer - , ddosMemoryShedHighWater :: Maybe Double - , ddosMaxConcurrentStreams :: Maybe Int - , ddosMaxHeaderBytes :: Maybe Int - , ddosSlowlorisSeconds :: Maybe Int - , ddosJailCooldownSeconds :: Maybe Int - , ddosReusePort :: Bool + { ddosEarlyDataReject :: !Bool + , ddosPerIPConnections :: !(Maybe Int) + , ddosMemoryShedBytes :: !(Maybe Integer) + , ddosMemoryShedHighWater :: !(Maybe Double) + , ddosMaxConcurrentStreams :: !(Maybe Int) + , ddosMaxHeaderBytes :: !(Maybe Int) + , ddosSlowlorisSeconds :: !(Maybe Int) + , ddosJailCooldownSeconds :: !(Maybe Int) + , ddosReusePort :: !Bool } deriving (Show, Eq, Generic) instance FromJSON DDoSConfig where parseJSON = withObject "DDoSConfig" $ \v -> DDoSConfig - <$> v .:? "early_data_reject" .!= True + <$> v .:? "early_data_reject" .!= True <*> v .:? "per_ip_connections" <*> v .:? "memory_shed_bytes" <*> v .:? "memory_shed_high_water" @@ -72,41 +88,39 @@ instance FromJSON DDoSConfig where <*> v .:? "max_header_bytes" <*> v .:? "slowloris_seconds" <*> v .:? "jail_cooldown_seconds" - <*> v .:? "reuse_port" .!= False + <*> v .:? "reuse_port" .!= False defaultDDoSConfig :: DDoSConfig defaultDDoSConfig = DDoSConfig - { ddosEarlyDataReject = True - , ddosPerIPConnections = Nothing - , ddosMemoryShedBytes = Nothing - , ddosMemoryShedHighWater = Nothing + { ddosEarlyDataReject = True + , ddosPerIPConnections = Nothing + , ddosMemoryShedBytes = Nothing + , ddosMemoryShedHighWater = Nothing , ddosMaxConcurrentStreams = Nothing - , ddosMaxHeaderBytes = Nothing - , ddosSlowlorisSeconds = Nothing - , ddosJailCooldownSeconds = Nothing - , ddosReusePort = False + , ddosMaxHeaderBytes = Nothing + , ddosSlowlorisSeconds = Nothing + , ddosJailCooldownSeconds = Nothing + , ddosReusePort = False } --- | Listen port configuration data ListenConfig = ListenConfig - { listenPort :: Int - , listenTLS :: Maybe TLSConfig - , listenRedirectHTTPS :: Maybe Bool -- Redirect HTTP to HTTPS? + { listenPort :: !Int + , listenTLS :: !(Maybe TLSConfig) + , listenRedirectHTTPS :: !(Maybe Bool) } deriving (Show, Eq, Generic) instance FromJSON ListenConfig where parseJSON = withObject "ListenConfig" $ \v -> ListenConfig - <$> v .: "port" + <$> v .: "port" <*> v .:? "tls" <*> v .:? "redirect_https" --- | TLS/SSL configuration (supports both single cert and SNI) data TLSConfig = TLSConfig - { tlsCert :: Maybe FilePath -- Single cert (if not using SNI) - , tlsKey :: Maybe FilePath -- Single key (if not using SNI) - , tlsSNI :: Maybe [SNIDomain] -- SNI domains (multiple certs) - , tlsDefaultCert :: Maybe FilePath -- Default cert for SNI - , tlsDefaultKey :: Maybe FilePath -- Default key for SNI + { tlsCert :: !(Maybe FilePath) + , tlsKey :: !(Maybe FilePath) + , tlsSNI :: !(Maybe [SNIDomain]) + , tlsDefaultCert :: !(Maybe FilePath) + , tlsDefaultKey :: !(Maybe FilePath) } deriving (Show, Eq, Generic) instance FromJSON TLSConfig where @@ -117,11 +131,10 @@ instance FromJSON TLSConfig where <*> v .:? "default_cert" <*> v .:? "default_key" --- | SNI domain configuration data SNIDomain = SNIDomain - { sniDomain :: Text - , sniCert :: FilePath - , sniKey :: FilePath + { sniDomain :: !Text + , sniCert :: !FilePath + , sniKey :: !FilePath } deriving (Show, Eq, Generic) instance FromJSON SNIDomain where @@ -130,23 +143,21 @@ instance FromJSON SNIDomain where <*> v .: "cert" <*> v .: "key" --- | Upstream backend definition data Upstream = Upstream - { upstreamName :: Text - , upstreamServers :: [Server] - , upstreamHealthCheck :: Maybe HealthCheck + { upstreamName :: !Text + , upstreamServers :: ![Server] + , upstreamHealthCheck :: !(Maybe HealthCheck) } deriving (Show, Eq, Generic) instance FromJSON Upstream where parseJSON = withObject "Upstream" $ \v -> Upstream - <$> v .: "name" - <*> v .: "servers" + <$> v .: "name" + <*> v .: "servers" <*> v .:? "health_check" --- | Backend server with weight for load balancing data Server = Server - { serverHost :: Text - , serverWeight :: Int + { serverHost :: !Text + , serverWeight :: !Int } deriving (Show, Eq, Generic) instance FromJSON Server where @@ -154,10 +165,9 @@ instance FromJSON Server where <$> v .: "host" <*> v .: "weight" --- | Health check configuration data HealthCheck = HealthCheck - { healthCheckPath :: Text - , healthCheckInterval :: Text -- e.g., "10s" + { healthCheckPath :: !Text + , healthCheckInterval :: !Text } deriving (Show, Eq, Generic) instance FromJSON HealthCheck where @@ -165,10 +175,9 @@ instance FromJSON HealthCheck where <$> v .: "path" <*> v .: "interval" --- | Route definition (virtual host + paths) data Route = Route - { routeHost :: Text - , routePaths :: [PathRoute] + { routeHost :: !Text + , routePaths :: ![PathRoute] } deriving (Show, Eq, Generic) instance FromJSON Route where @@ -176,122 +185,99 @@ instance FromJSON Route where <$> v .: "host" <*> v .: "paths" --- | Path-based routing rule data PathRoute = PathRoute - { pathRoutePath :: Text - , pathRouteUpstream :: Text - , pathRouteRateLimit :: Maybe Text -- e.g., "100/minute" + { pathRoutePath :: !Text + , pathRouteUpstream :: !Text + , pathRouteRateLimit :: !(Maybe Text) } deriving (Show, Eq, Generic) instance FromJSON PathRoute where parseJSON = withObject "PathRoute" $ \v -> PathRoute - <$> v .: "path" - <*> v .: "upstream" + <$> v .: "path" + <*> v .: "upstream" <*> v .:? "rate_limit" --- | Load configuration from YAML file loadConfig :: FilePath -> IO (Either String Config) loadConfig path = do result <- decodeFileEither path - return $ case result of - Left err -> Left (show err) + pure $ case result of + Left err -> Left (show err) Right config -> Right config --- | Validate configuration for correctness validateConfig :: Config -> Either String () validateConfig config = do - -- Check version - when (configVersion config /= 1) $ - Left "Unsupported config version (expected: 1)" + when (configVersion config /= supportedConfigVersion) $ + Left ("Unsupported config version (expected: " + ++ show supportedConfigVersion ++ ")") - -- Check at least one listen port - when (null $ configListen config) $ + when (null (configListen config)) $ Left "At least one listen port must be specified" - -- Check port numbers are valid forM_ (configListen config) $ \listen -> do let port = listenPort listen - when (port < 1 || port > 65535) $ - Left $ "Invalid port number: " ++ show port - - -- Validate TLS configuration if present + when (port < minPort || port > maxPort) $ + Left ("Invalid port number: " ++ show port) case listenTLS listen of - Nothing -> return () - Just tlsConf -> validateTLS tlsConf + Nothing -> pure () + Just tlsConf -> validateTLS tlsConf - -- Check at least one upstream - when (null $ configUpstreams config) $ + when (null (configUpstreams config)) $ Left "At least one upstream must be specified" - -- Check upstream names are unique let upstreamNames = map upstreamName (configUpstreams config) - when (length upstreamNames /= length (nubText upstreamNames)) $ + when (length upstreamNames /= length (nub upstreamNames)) $ Left "Upstream names must be unique" - -- Check each upstream has at least one server forM_ (configUpstreams config) $ \upstream -> do - when (null $ upstreamServers upstream) $ - Left $ "Upstream '" ++ T.unpack (upstreamName upstream) ++ "' has no servers" + when (null (upstreamServers upstream)) $ + Left ("Upstream '" ++ T.unpack (upstreamName upstream) + ++ "' has no servers") + forM_ (upstreamServers upstream) $ \server -> + when (serverWeight server < minServerWeight) $ + Left ("Server weight must be positive: " + ++ T.unpack (serverHost server)) - -- Check server weights are positive - forM_ (upstreamServers upstream) $ \server -> do - when (serverWeight server < 1) $ - Left $ "Server weight must be positive: " ++ T.unpack (serverHost server) - - -- Check at least one route - when (null $ configRoutes config) $ + when (null (configRoutes config)) $ Left "At least one route must be specified" - -- Validate upstream references in routes forM_ (configRoutes config) $ \route -> do - when (null $ routePaths route) $ - Left $ "Route for host '" ++ T.unpack (routeHost route) ++ "' has no paths" - + when (null (routePaths route)) $ + Left ("Route for host '" ++ T.unpack (routeHost route) + ++ "' has no paths") forM_ (routePaths route) $ \pathRoute -> do let upstreamRef = pathRouteUpstream pathRoute when (upstreamRef `notElem` upstreamNames) $ - Left $ "Unknown upstream referenced: '" ++ T.unpack upstreamRef ++ "'" + Left ("Unknown upstream referenced: '" + ++ T.unpack upstreamRef ++ "'") - return () - where - -- Helper to remove duplicates from Text list - nubText :: [Text] -> [Text] - nubText [] = [] - nubText (x:xs) = x : nubText (filter (/= x) xs) + pure () - -- Validate TLS configuration - validateTLS :: TLSConfig -> Either String () - validateTLS tlsConf = do - let hasSingleCert = case (tlsCert tlsConf, tlsKey tlsConf) of - (Just _, Just _) -> True - (Nothing, Nothing) -> False - _ -> False -- One is set but not the other +validateTLS :: TLSConfig -> Either String () +validateTLS tlsConf = do + let hasSingleCert = case (tlsCert tlsConf, tlsKey tlsConf) of + (Just _, Just _) -> True + _ -> False + hasSNI = case (tlsSNI tlsConf, tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of + (Just sniDomains, Just _, Just _) -> not (null sniDomains) + _ -> False - hasSNI = case (tlsSNI tlsConf, tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of - (Just sniDomains, Just _, Just _) -> not (null sniDomains) - _ -> False + when (not hasSingleCert && not hasSNI) $ + Left "TLS configuration must specify either (cert + key) or (sni + default_cert + default_key)" - -- Must have either single cert or SNI configuration - when (not hasSingleCert && not hasSNI) $ - Left "TLS configuration must specify either (cert + key) or (sni + default_cert + default_key)" + when (hasSingleCert && hasSNI) $ + Left "TLS configuration cannot have both single cert and SNI configuration" - -- Can't have both single cert and SNI - when (hasSingleCert && hasSNI) $ - Left "TLS configuration cannot have both single cert and SNI configuration" + when hasSingleCert $ + case (tlsCert tlsConf, tlsKey tlsConf) of + (Just _, Nothing) -> Left "TLS cert specified but key missing" + (Nothing, Just _) -> Left "TLS key specified but cert missing" + _ -> pure () - -- If single cert, ensure both cert and key are present - when (hasSingleCert) $ do - case (tlsCert tlsConf, tlsKey tlsConf) of - (Just _, Nothing) -> Left "TLS cert specified but key missing" - (Nothing, Just _) -> Left "TLS key specified but cert missing" - _ -> return () + when hasSNI $ + case (tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of + (Just _, Nothing) -> Left "SNI default_cert specified but default_key missing" + (Nothing, Just _) -> Left "SNI default_key specified but default_cert missing" + (Nothing, Nothing) -> Left "SNI configuration requires default_cert and default_key" + _ -> pure () - -- If SNI, ensure default cert/key are present - when (hasSNI) $ do - case (tlsDefaultCert tlsConf, tlsDefaultKey tlsConf) of - (Just _, Nothing) -> Left "SNI default_cert specified but default_key missing" - (Nothing, Just _) -> Left "SNI default_key specified but default_cert missing" - (Nothing, Nothing) -> Left "SNI configuration requires default_cert and default_key" - _ -> return () - - return () + pure () diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/DDoS/ConnLimit.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/DDoS/ConnLimit.hs index 67290f4e..a5d302ee 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/DDoS/ConnLimit.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/DDoS/ConnLimit.hs @@ -30,6 +30,7 @@ import Control.Concurrent.STM ) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 +import Data.List (intercalate) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Network.Socket @@ -101,9 +102,4 @@ ipBytesFromSockAddr (SockAddrUnix p) = BS8.pack ("unix:" <> p) v6Bytes :: HostAddress6 -> ByteString v6Bytes ha = let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple ha - in BS8.pack (joinColons (map (`showHex` "") [a, b, c, d, e, f, g, h])) - -joinColons :: [String] -> String -joinColons [] = "" -joinColons [x] = x -joinColons (x : xs) = x <> ":" <> joinColons xs + in BS8.pack (intercalate ":" (map (`showHex` "") [a, b, c, d, e, f, g, h])) diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Fingerprint/JA4H.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Fingerprint/JA4H.hs index 1b82af45..45085ba7 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Fingerprint/JA4H.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Fingerprint/JA4H.hs @@ -88,11 +88,6 @@ refererHeaderName = "referer" acceptLanguageHeaderName :: CI ByteString acceptLanguageHeaderName = "accept-language" -lookupCI :: CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString -lookupCI k hs = case filter ((== k) . fst) hs of - ((_, v) : _) -> Just v - _ -> Nothing - acceptLanguagePrefix :: ByteString -> ByteString acceptLanguagePrefix bs = let firstTag = BS.takeWhile (\c -> c /= 0x2c && c /= 0x3b && c /= 0x20) bs @@ -136,7 +131,7 @@ computeJA4H req = filter (\(k, _) -> k /= cookieHeaderName && k /= refererHeaderName) rawHeaders headerCount = padTwo (length filteredHeaders) langPrefix = maybe "0000" acceptLanguagePrefix - $ lookupCI acceptLanguageHeaderName rawHeaders + $ lookup acceptLanguageHeaderName rawHeaders partA = BS.concat [method, version, cookieFlag, refererFlag, headerCount, langPrefix] headerNameList = BS.intercalate "," (map (CI.original . fst) filteredHeaders) headerHash = hashTruncated headerNameList diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/HealthCheck.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/HealthCheck.hs index 9e6b949b..46342f69 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/HealthCheck.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/HealthCheck.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE RecordWildCards #-} +{- +©AngelaMos | 2026 +HealthCheck.hs +-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} module Aenebris.HealthCheck ( HealthCheckConfig(..) @@ -10,10 +14,11 @@ module Aenebris.HealthCheck ) where import Aenebris.Backend +import Aenebris.Connection (httpOkStatusCode, microsPerSecond) import Control.Concurrent (threadDelay) import Control.Concurrent.Async import Control.Concurrent.STM -import Control.Monad (forever) +import Control.Monad (forever, zipWithM_) import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) @@ -21,71 +26,67 @@ import Network.HTTP.Client import Network.HTTP.Types.Status (statusCode) import System.Timeout (timeout) --- | Health check configuration +defaultHealthCheckIntervalSeconds :: Int +defaultHealthCheckIntervalSeconds = 10 + +defaultHealthCheckTimeoutSeconds :: Int +defaultHealthCheckTimeoutSeconds = 2 + +defaultHealthCheckMaxFailures :: Int +defaultHealthCheckMaxFailures = 3 + +defaultHealthCheckRecoveryAttempts :: Int +defaultHealthCheckRecoveryAttempts = 2 + +defaultHealthCheckEndpoint :: Text +defaultHealthCheckEndpoint = "/health" + data HealthCheckConfig = HealthCheckConfig - { hcInterval :: Int -- Seconds between checks - , hcTimeout :: Int -- Request timeout (seconds) - , hcEndpoint :: Text -- Health endpoint path (e.g., "/health") - , hcMaxFailures :: Int -- Failures before marking unhealthy - , hcRecoveryAttempts :: Int -- Successes before marking healthy + { hcInterval :: !Int + , hcTimeout :: !Int + , hcEndpoint :: !Text + , hcMaxFailures :: !Int + , hcRecoveryAttempts :: !Int } --- | Default health check configuration defaultHealthCheckConfig :: HealthCheckConfig defaultHealthCheckConfig = HealthCheckConfig - { hcInterval = 10 - , hcTimeout = 2 - , hcEndpoint = "/health" - , hcMaxFailures = 3 - , hcRecoveryAttempts = 2 + { hcInterval = defaultHealthCheckIntervalSeconds + , hcTimeout = defaultHealthCheckTimeoutSeconds + , hcEndpoint = defaultHealthCheckEndpoint + , hcMaxFailures = defaultHealthCheckMaxFailures + , hcRecoveryAttempts = defaultHealthCheckRecoveryAttempts } --- | Start health checker (returns Async handle for stopping) -startHealthChecker :: Manager -> HealthCheckConfig -> [RuntimeBackend] -> IO (Async ()) +startHealthChecker + :: Manager -> HealthCheckConfig -> [RuntimeBackend] -> IO (Async ()) startHealthChecker manager config backends = - async $ healthCheckLoop manager config backends + async (healthCheckLoop manager config backends) --- | Stop health checker stopHealthChecker :: Async () -> IO () stopHealthChecker = cancel --- | Main health check loop healthCheckLoop :: Manager -> HealthCheckConfig -> [RuntimeBackend] -> IO () healthCheckLoop manager config backends = forever $ do - -- Check all backends concurrently results <- mapConcurrently (performHealthCheck manager config) backends - - -- Update backend states based on results atomically $ zipWithM_ (updateBackendState config) backends results + threadDelay (hcInterval config * microsPerSecond) - threadDelay (hcInterval config * 1000000) - --- | Perform HTTP health check on a backend performHealthCheck :: Manager -> HealthCheckConfig -> RuntimeBackend -> IO Bool performHealthCheck manager config backend = do let url = "http://" ++ T.unpack (rbHost backend) ++ T.unpack (hcEndpoint config) - - -- Try to make request with timeout - result <- timeout (hcTimeout config * 1000000) $ do + result <- timeout (hcTimeout config * microsPerSecond) $ do req <- parseRequest url response <- httpLbs req manager - return $ statusCode (responseStatus response) == 200 - - -- Update last check time + pure (statusCode (responseStatus response) == httpOkStatusCode) now <- getCurrentTime atomically $ writeTVar (rbLastHealthCheck backend) (Just now) - - return $ case result of + pure $ case result of Just True -> True - _ -> False + _ -> False --- | Update backend state based on health check result updateBackendState :: HealthCheckConfig -> RuntimeBackend -> Bool -> STM () updateBackendState config backend healthy = if healthy then recordSuccess backend (hcRecoveryAttempts config) else recordFailure backend (hcMaxFailures config) - --- | Helper: zip with monadic action -zipWithM_ :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m () -zipWithM_ f xs ys = sequence_ (zipWith f xs ys) diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Honeypot.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Honeypot.hs index c1d90cc7..0e819b4f 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Honeypot.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Honeypot.hs @@ -47,7 +47,7 @@ import qualified Data.Text.Encoding as TE import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import Data.Word (Word64) import GHC.Generics (Generic) -import Network.HTTP.Types (Status, mkStatus) +import Network.HTTP.Types (status200, status404) import Network.Wai ( Middleware , Response @@ -219,12 +219,6 @@ trapLabel :: TrapPattern -> ByteString trapLabel (TrapExact e) = e trapLabel (TrapPrefix p) = p <> "*" -status404 :: Status -status404 = mkStatus 404 "Not Found" - -status200 :: Status -status200 = mkStatus 200 "OK" - honeypotMiddleware :: HoneypotConfig -> Maybe IPJail -> Middleware honeypotMiddleware cfg@HoneypotConfig{..} mJail app req respond | hpServeRobotsTxt && requestMethod req == "GET" diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/LoadBalancer.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/LoadBalancer.hs index 48de738a..56b82f8f 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/LoadBalancer.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/LoadBalancer.hs @@ -1,3 +1,7 @@ +{- +©AngelaMos | 2026 +LoadBalancer.hs +-} {-# LANGUAGE RecordWildCards #-} module Aenebris.LoadBalancer @@ -9,142 +13,94 @@ module Aenebris.LoadBalancer import Aenebris.Backend import Control.Concurrent.STM +import Control.Monad (filterM, forM_) import Data.IORef -import Data.List (minimumBy, find) +import Data.List (maximumBy, minimumBy) import Data.Ord (comparing) import qualified Data.Vector as V import Data.Vector (Vector, (!)) --- | Load balancing strategy +initialRoundRobinIndex :: Int +initialRoundRobinIndex = 0 + data LoadBalancerStrategy = RoundRobin | LeastConnections | WeightedRoundRobin deriving (Eq, Show) --- | Load balancer state data LoadBalancer = LoadBalancer - { lbBackends :: Vector RuntimeBackend - , lbStrategy :: LoadBalancerStrategy - , lbRRCounter :: IORef Int -- For round robin + { lbBackends :: !(Vector RuntimeBackend) + , lbStrategy :: !LoadBalancerStrategy + , lbRRCounter :: !(IORef Int) } --- | Create a load balancer for given backends -createLoadBalancer :: LoadBalancerStrategy -> [RuntimeBackend] -> IO LoadBalancer +createLoadBalancer + :: LoadBalancerStrategy -> [RuntimeBackend] -> IO LoadBalancer createLoadBalancer strategy backends = do - counter <- newIORef 0 - return LoadBalancer - { lbBackends = V.fromList backends - , lbStrategy = strategy + counter <- newIORef initialRoundRobinIndex + pure LoadBalancer + { lbBackends = V.fromList backends + , lbStrategy = strategy , lbRRCounter = counter } --- | Select a backend using the configured strategy selectBackend :: LoadBalancer -> IO (Maybe RuntimeBackend) -selectBackend lb = - case lbStrategy lb of - RoundRobin -> selectRoundRobin lb - LeastConnections -> selectLeastConnections lb - WeightedRoundRobin -> selectWeightedRR lb +selectBackend lb = case lbStrategy lb of + RoundRobin -> selectRoundRobin lb + LeastConnections -> selectLeastConnections lb + WeightedRoundRobin -> selectWeightedRR lb --- Round-Robin Implementation (IORef-based, fastest) selectRoundRobin :: LoadBalancer -> IO (Maybe RuntimeBackend) selectRoundRobin LoadBalancer{..} = do let backends = lbBackends - len = V.length backends - + len = V.length backends if len == 0 - then return Nothing + then pure Nothing else do - -- Get next index idx <- atomicModifyIORef' lbRRCounter $ \i -> let next = (i + 1) `mod` len in (next, i) - - -- Find next healthy backend (try all, wrapping around) findHealthyBackend backends idx len --- | Find next healthy backend starting from index -findHealthyBackend :: Vector RuntimeBackend -> Int -> Int -> IO (Maybe RuntimeBackend) -findHealthyBackend backends startIdx totalBackends = - go startIdx totalBackends +findHealthyBackend + :: Vector RuntimeBackend -> Int -> Int -> IO (Maybe RuntimeBackend) +findHealthyBackend backends startIdx totalBackends = go startIdx totalBackends where len = V.length backends - go currentIdx remaining - | remaining <= 0 = return Nothing -- Tried all, none healthy + | remaining <= 0 = pure Nothing | otherwise = do let backend = backends ! currentIdx - healthy <- atomically $ isHealthy backend - + healthy <- atomically (isHealthy backend) if healthy - then return (Just backend) + then pure (Just backend) else go ((currentIdx + 1) `mod` len) (remaining - 1) - --- Least Connections Implementation (STM-based) selectLeastConnections :: LoadBalancer -> IO (Maybe RuntimeBackend) selectLeastConnections LoadBalancer{..} = atomically $ do let backends = V.toList lbBackends - - -- Filter to only healthy backends healthy <- filterM isHealthy backends - case healthy of - [] -> return Nothing - backends' -> do - -- Get connection counts for all healthy backends - counts <- mapM getConnectionCount backends' + [] -> pure Nothing + chosen -> do + counts <- mapM getConnectionCount chosen + let (_, minBackend) = minimumBy (comparing fst) (zip counts chosen) + pure (Just minBackend) - -- Find backend with minimum connections - let (_, minBackend) = minimumBy (comparing fst) (zip counts backends') - - return (Just minBackend) - - --- Smooth Weighted Round-Robin (nginx algorithm, STM-based) selectWeightedRR :: LoadBalancer -> IO (Maybe RuntimeBackend) selectWeightedRR LoadBalancer{..} = atomically $ do let backends = V.toList lbBackends - - -- Filter to only healthy backends healthy <- filterM isHealthy backends - case healthy of - [] -> return Nothing - backends' -> do - -- Step 1: Increase each backend's current weight by its base weight - forM_ backends' $ \rb -> do - currentW <- readTVar (rbCurrentWeight rb) - let newWeight = currentW + rbWeight rb - writeTVar (rbCurrentWeight rb) newWeight - - -- Step 2: Select backend with maximum current weight - weights <- mapM getCurrentWeight backends' - let maxWeight = maximum weights - selectedIdx = find (\i -> weights !! i == maxWeight) [0..length weights - 1] - selected = backends' !! (fromMaybe 0 selectedIdx) - - -- Step 3: Reduce selected backend's current weight by total weight - let totalWeight = sum (map rbWeight backends') - currentW <- readTVar (rbCurrentWeight selected) - writeTVar (rbCurrentWeight selected) (currentW - totalWeight) - - return (Just selected) - --- Helper: STM filter -filterM :: Monad m => (a -> m Bool) -> [a] -> m [a] -filterM _ [] = return [] -filterM p (x:xs) = do - b <- p x - rest <- filterM p xs - return $ if b then x : rest else rest - --- Helper: fromMaybe -fromMaybe :: a -> Maybe a -> a -fromMaybe def Nothing = def -fromMaybe _ (Just x) = x - --- Helper: forM_ -forM_ :: Monad m => [a] -> (a -> m b) -> m () -forM_ xs f = sequence_ (map f xs) + [] -> pure Nothing + chosen -> do + forM_ chosen $ \rb -> + modifyTVar' (rbCurrentWeight rb) (+ rbWeight rb) + tagged <- mapM + (\rb -> (\w -> (w, rb)) <$> readTVar (rbCurrentWeight rb)) + chosen + let (_, picked) = maximumBy (comparing fst) tagged + totalWeight = sum (map rbWeight chosen) + modifyTVar' (rbCurrentWeight picked) (subtract totalWeight) + pure (Just picked) diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Features.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Features.hs index 8955505d..d2519a05 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Features.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Features.hs @@ -494,17 +494,17 @@ extractFeatures FeatureContext{..} req = let !headers = requestHeaders req !path = rawPathInfo req !method = requestMethod req - !mAcceptLang = lookupCI acceptLanguageHeader headers - !mUserAgent = lookupCI userAgentHeader headers - !mAcceptEnc = lookupCI acceptEncodingHeader headers - !mReferer = lookupCI refererHeader headers - !mCookie = lookupCI cookieHeader headers - !mSecChUa = lookupCI secChUaHeader headers - !mSecChPlat = lookupCI secChUaPlatformHeader headers - !mSecFetchSite = lookupCI secFetchSiteHeader headers - !mSecFetchMode = lookupCI secFetchModeHeader headers - !mSecFetchDest = lookupCI secFetchDestHeader headers - !mAccept = lookupCI acceptHeader headers + !mAcceptLang = lookup acceptLanguageHeader headers + !mUserAgent = lookup userAgentHeader headers + !mAcceptEnc = lookup acceptEncodingHeader headers + !mReferer = lookup refererHeader headers + !mCookie = lookup cookieHeader headers + !mSecChUa = lookup secChUaHeader headers + !mSecChPlat = lookup secChUaPlatformHeader headers + !mSecFetchSite = lookup secFetchSiteHeader headers + !mSecFetchMode = lookup secFetchModeHeader headers + !mSecFetchDest = lookup secFetchDestHeader headers + !mAccept = lookup acceptHeader headers !uaBytes = fromMaybe BS.empty mUserAgent !uaLen = BS.length uaBytes !depth = pathDepth path @@ -552,8 +552,3 @@ extractFeatures FeatureContext{..} req = , fHeaderOrderCanonical = boolToDouble (headerOrderIsCanonicalBrowser headers) } - -lookupCI :: CI ByteString -> [(CI ByteString, ByteString)] -> Maybe ByteString -lookupCI k hs = case filter ((== k) . fst) hs of - ((_, v) : _) -> Just v - _ -> Nothing diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Middleware/Redirect.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Middleware/Redirect.hs index c0a5e955..a08b8aaf 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Middleware/Redirect.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Middleware/Redirect.hs @@ -1,3 +1,7 @@ +{- +©AngelaMos | 2026 +Redirect.hs +-} {-# LANGUAGE OverloadedStrings #-} module Aenebris.Middleware.Redirect @@ -7,38 +11,44 @@ module Aenebris.Middleware.Redirect import qualified Data.ByteString.Char8 as BS import Data.Maybe (fromMaybe) -import Network.HTTP.Types (status301, hLocation) -import Network.Wai (Middleware, responseLBS, requestHeaderHost, rawPathInfo, rawQueryString, isSecure) +import Network.HTTP.Types (hLocation, status301) +import Network.Wai + ( Middleware + , isSecure + , rawPathInfo + , rawQueryString + , requestHeaderHost + , responseLBS + ) + +defaultHostFallback :: BS.ByteString +defaultHostFallback = "localhost" + +httpsScheme :: BS.ByteString +httpsScheme = "https://" + +standardHttpsPort :: Int +standardHttpsPort = 443 + +redirectBody :: BS.ByteString +redirectBody = "Redirecting to HTTPS" --- | Redirect HTTP requests to HTTPS (assumes HTTPS is on port 443) httpsRedirect :: Middleware httpsRedirect = httpsRedirectWithPort Nothing --- | Redirect HTTP requests to HTTPS with optional custom port --- If port is Nothing, assumes 443 (standard HTTPS port, no port in URL) --- If port is Just n, includes :n in the redirect URL httpsRedirectWithPort :: Maybe Int -> Middleware httpsRedirectWithPort httpsPort app req respond - | isSecure req = app req respond -- Already HTTPS, pass through + | isSecure req = app req respond | otherwise = do - -- Get host from Host header - let hostHeader = fromMaybe "localhost" $ requestHeaderHost req - - -- Build HTTPS URL with optional port + let hostHeader = fromMaybe defaultHostFallback (requestHeaderHost req) host = case httpsPort of - Nothing -> hostHeader -- Standard 443, don't include port - Just 443 -> hostHeader -- Standard 443, don't include port + Nothing -> hostHeader + Just port | port == standardHttpsPort -> hostHeader Just port -> hostHeader <> ":" <> BS.pack (show port) - - -- Get path and query string (already encoded in rawPathInfo) - path = rawPathInfo req - query = rawQueryString req - - -- Build full redirect URL - redirectUrl = "https://" <> host <> path <> query - - -- Send 301 permanent redirect + path = rawPathInfo req + query = rawQueryString req + redirectUrl = httpsScheme <> host <> path <> query respond $ responseLBS status301 [(hLocation, redirectUrl)] - "Redirecting to HTTPS" + (BS.fromStrict redirectBody) diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Middleware/Security.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Middleware/Security.hs index 9706b41d..d49da10d 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Middleware/Security.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Middleware/Security.hs @@ -1,3 +1,7 @@ +{- +©AngelaMos | 2026 +Security.hs +-} {-# LANGUAGE OverloadedStrings #-} module Aenebris.Middleware.Security @@ -11,125 +15,101 @@ module Aenebris.Middleware.Security import Data.ByteString (ByteString) import qualified Data.CaseInsensitive as CI +import Data.Maybe (catMaybes) import Network.HTTP.Types (Header, ResponseHeaders) import Network.Wai (Middleware, mapResponseHeaders) --- | Security level presets data SecurityLevel - = Testing -- Short HSTS, permissive CSP, for development - | Production -- Balanced security for production - | Strict -- Maximum security, strict CSP, HSTS preload + = Testing + | Production + | Strict deriving (Show, Eq) --- | Security configuration data SecurityConfig = SecurityConfig - { scHSTS :: Maybe ByteString -- Strict-Transport-Security header - , scCSP :: Maybe ByteString -- Content-Security-Policy header - , scFrameOptions :: Maybe ByteString -- X-Frame-Options header - , scContentTypeOptions :: Bool -- X-Content-Type-Options: nosniff - , scReferrerPolicy :: Maybe ByteString -- Referrer-Policy header - , scPermissionsPolicy :: Maybe ByteString -- Permissions-Policy header - , scXSSProtection :: Maybe ByteString -- X-XSS-Protection (legacy, but some crawlers check) - , scExpectCT :: Maybe ByteString -- Expect-CT (transitional) - , scServerHeader :: Maybe ByteString -- Server header (hide or customize) - , scRemovePoweredBy :: Bool -- Remove X-Powered-By headers + { scHSTS :: !(Maybe ByteString) + , scCSP :: !(Maybe ByteString) + , scFrameOptions :: !(Maybe ByteString) + , scContentTypeOptions :: !Bool + , scReferrerPolicy :: !(Maybe ByteString) + , scPermissionsPolicy :: !(Maybe ByteString) + , scXSSProtection :: !(Maybe ByteString) + , scExpectCT :: !(Maybe ByteString) + , scServerHeader :: !(Maybe ByteString) + , scRemovePoweredBy :: !Bool } deriving (Show, Eq) --- | Testing/development security configuration --- Use short HSTS for easy testing, permissive CSP testingSecurityConfig :: SecurityConfig testingSecurityConfig = SecurityConfig - { scHSTS = Just "max-age=300" -- 5 minutes for testing - , scCSP = Just "default-src 'self' 'unsafe-inline' 'unsafe-eval'; script-src 'self' 'unsafe-inline' 'unsafe-eval'; style-src 'self' 'unsafe-inline'" - , scFrameOptions = Just "SAMEORIGIN" - , scContentTypeOptions = True - , scReferrerPolicy = Just "strict-origin-when-cross-origin" - , scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=()" - , scXSSProtection = Just "1; mode=block" - , scExpectCT = Nothing - , scServerHeader = Just "Aenebris/0.1.0" - , scRemovePoweredBy = True + { scHSTS = Just "max-age=300" + , scCSP = Just "default-src 'self' 'unsafe-inline' 'unsafe-eval'; script-src 'self' 'unsafe-inline' 'unsafe-eval'; style-src 'self' 'unsafe-inline'" + , scFrameOptions = Just "SAMEORIGIN" + , scContentTypeOptions = True + , scReferrerPolicy = Just "strict-origin-when-cross-origin" + , scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=()" + , scXSSProtection = Just "1; mode=block" + , scExpectCT = Nothing + , scServerHeader = Just "Aenebris/0.1.0" + , scRemovePoweredBy = True } --- | Production security configuration --- Balanced security, 1-month HSTS defaultSecurityConfig :: SecurityConfig defaultSecurityConfig = SecurityConfig - { scHSTS = Just "max-age=2592000; includeSubDomains" -- 30 days - , scCSP = Just "default-src 'self'; script-src 'self'; style-src 'self' 'unsafe-inline'; img-src 'self' data: https:; font-src 'self' data:; connect-src 'self'; frame-ancestors 'none'" - , scFrameOptions = Just "DENY" - , scContentTypeOptions = True - , scReferrerPolicy = Just "strict-origin-when-cross-origin" - , scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=()" - , scXSSProtection = Just "1; mode=block" - , scExpectCT = Just "max-age=86400, enforce" - , scServerHeader = Just "Aenebris" -- Don't reveal version in production - , scRemovePoweredBy = True + { scHSTS = Just "max-age=2592000; includeSubDomains" + , scCSP = Just "default-src 'self'; script-src 'self'; style-src 'self' 'unsafe-inline'; img-src 'self' data: https:; font-src 'self' data:; connect-src 'self'; frame-ancestors 'none'" + , scFrameOptions = Just "DENY" + , scContentTypeOptions = True + , scReferrerPolicy = Just "strict-origin-when-cross-origin" + , scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=()" + , scXSSProtection = Just "1; mode=block" + , scExpectCT = Just "max-age=86400, enforce" + , scServerHeader = Just "Aenebris" + , scRemovePoweredBy = True } --- | Strict security configuration for maximum protection --- 2-year HSTS with preload, very restrictive CSP strictSecurityConfig :: SecurityConfig strictSecurityConfig = SecurityConfig - { scHSTS = Just "max-age=63072000; includeSubDomains; preload" -- 2 years + preload - , scCSP = Just "default-src 'none'; script-src 'self'; style-src 'self'; img-src 'self' data:; font-src 'self'; connect-src 'self'; frame-ancestors 'none'; base-uri 'self'; form-action 'self'; upgrade-insecure-requests" - , scFrameOptions = Just "DENY" - , scContentTypeOptions = True - , scReferrerPolicy = Just "no-referrer" -- Strictest, no referrer leakage - , scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=(), bluetooth=(), display-capture=(), document-domain=()" - , scXSSProtection = Just "1; mode=block" - , scExpectCT = Just "max-age=86400, enforce" - , scServerHeader = Nothing -- Hide completely - , scRemovePoweredBy = True + { scHSTS = Just "max-age=63072000; includeSubDomains; preload" + , scCSP = Just "default-src 'none'; script-src 'self'; style-src 'self'; img-src 'self' data:; font-src 'self'; connect-src 'self'; frame-ancestors 'none'; base-uri 'self'; form-action 'self'; upgrade-insecure-requests" + , scFrameOptions = Just "DENY" + , scContentTypeOptions = True + , scReferrerPolicy = Just "no-referrer" + , scPermissionsPolicy = Just "geolocation=(), microphone=(), camera=(), payment=(), usb=(), magnetometer=(), gyroscope=(), accelerometer=(), bluetooth=(), display-capture=(), document-domain=()" + , scXSSProtection = Just "1; mode=block" + , scExpectCT = Just "max-age=86400, enforce" + , scServerHeader = Nothing + , scRemovePoweredBy = True } --- | Middleware that adds security headers to all responses addSecurityHeaders :: SecurityConfig -> Middleware addSecurityHeaders config app req respond = app req $ \res -> respond $ mapResponseHeaders (addHeaders config) res --- | Add security headers to response headers addHeaders :: SecurityConfig -> ResponseHeaders -> ResponseHeaders addHeaders config headers = - let - -- Remove headers we want to control - cleaned = if scRemovePoweredBy config - then filter (not . isPoweredBy) headers - else headers - - -- Build new security headers - newHeaders = catMaybes - [ fmap (\v -> ("Strict-Transport-Security", v)) (scHSTS config) - , fmap (\v -> ("Content-Security-Policy", v)) (scCSP config) - , fmap (\v -> ("X-Frame-Options", v)) (scFrameOptions config) - , if scContentTypeOptions config - then Just ("X-Content-Type-Options", "nosniff") - else Nothing - , fmap (\v -> ("Referrer-Policy", v)) (scReferrerPolicy config) - , fmap (\v -> ("Permissions-Policy", v)) (scPermissionsPolicy config) - , fmap (\v -> ("X-XSS-Protection", v)) (scXSSProtection config) - , fmap (\v -> ("Expect-CT", v)) (scExpectCT config) - ] - - -- Handle Server header specially - serverHeader = case scServerHeader config of - Just v -> [("Server", v)] - Nothing -> [] -- Remove Server header completely - - -- Remove existing Server header if we're replacing it - withoutServer = filter (not . isServerHeader) cleaned - + let cleaned = if scRemovePoweredBy config + then filter (not . isPoweredBy) headers + else headers + newHeaders = catMaybes + [ fmap (\v -> ("Strict-Transport-Security", v)) (scHSTS config) + , fmap (\v -> ("Content-Security-Policy", v)) (scCSP config) + , fmap (\v -> ("X-Frame-Options", v)) (scFrameOptions config) + , if scContentTypeOptions config + then Just ("X-Content-Type-Options", "nosniff") + else Nothing + , fmap (\v -> ("Referrer-Policy", v)) (scReferrerPolicy config) + , fmap (\v -> ("Permissions-Policy", v)) (scPermissionsPolicy config) + , fmap (\v -> ("X-XSS-Protection", v)) (scXSSProtection config) + , fmap (\v -> ("Expect-CT", v)) (scExpectCT config) + ] + serverHeader = case scServerHeader config of + Just v -> [("Server", v)] + Nothing -> [] + withoutServer = filter (not . isServerHeader) cleaned in withoutServer ++ newHeaders ++ serverHeader --- | Check if header is X-Powered-By isPoweredBy :: Header -> Bool isPoweredBy (name, _) = CI.mk name == CI.mk "X-Powered-By" --- | Check if header is Server isServerHeader :: Header -> Bool isServerHeader (name, _) = CI.mk name == CI.mk "Server" - --- | catMaybes implementation (since we're not importing Data.Maybe) -catMaybes :: [Maybe a] -> [a] -catMaybes = foldr (\mx xs -> case mx of Just x -> x:xs; Nothing -> xs) [] diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Proxy.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Proxy.hs index c8e3aea6..5da3745a 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Proxy.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Proxy.hs @@ -1,6 +1,10 @@ +{- +©AngelaMos | 2026 +Proxy.hs +-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} module Aenebris.Proxy ( ProxyState(..) @@ -25,7 +29,12 @@ import Aenebris.TLS import Aenebris.Tunnel import Aenebris.Middleware.Security import Aenebris.Middleware.Redirect -import Aenebris.RateLimit (RateLimiter, createRateLimiter, parseRateSpec, rateLimitMiddleware) +import Aenebris.RateLimit + ( RateLimiter + , createRateLimiter + , parseRateSpec + , rateLimitMiddleware + ) import Aenebris.DDoS.EarlyData (earlyDataGuard) import Aenebris.DDoS.MemoryShed ( MemoryShed @@ -72,7 +81,13 @@ import Aenebris.Geo ) import Control.Concurrent.STM (TVar, newTVarIO) import Control.Concurrent.Async (Async, async, waitAnyCancel) -import Control.Exception (try, SomeException) +import Control.Exception (SomeException, try) +import Control.Monad (unless, zipWithM) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString.Builder (byteString) +import qualified Data.ByteString.Lazy as LBS import Data.Function ((&)) import Data.List (sortBy) import Data.Map.Strict (Map) @@ -82,12 +97,16 @@ import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import Network.HTTP.Client (Manager, withResponse, parseRequest, RequestBody(..), brRead) +import Network.HTTP.Client + ( Manager + , RequestBody(..) + , brRead + , parseRequest + , withResponse + ) import qualified Network.HTTP.Client as HTTP import Network.HTTP.Types import Network.Wai -import Data.ByteString.Builder (byteString) -import Control.Monad (unless) import Network.Wai.Handler.Warp ( Settings , defaultSettings @@ -102,33 +121,77 @@ import Network.Wai.Handler.WarpTLS (runTLS) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) import System.Timeout (timeout) -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.ByteString.Lazy as LBS --- | Proxy runtime state +memoryShedPollIntervalMicros :: Int +memoryShedPollIntervalMicros = microsPerSecond + +contentTypePlain :: ByteString +contentTypePlain = "text/plain" + +bodyNotFound :: LBS.ByteString +bodyNotFound = "Not Found: No route configured for this host/path" + +bodyUpstreamMisconfigured :: LBS.ByteString +bodyUpstreamMisconfigured = "Internal Server Error: Upstream configuration error" + +bodyNoHealthyBackends :: LBS.ByteString +bodyNoHealthyBackends = "Service Unavailable: No healthy backends available" + +bodyBadGateway :: LBS.ByteString +bodyBadGateway = "Bad Gateway: Could not connect to backend server" + +bodyGatewayTimeout :: LBS.ByteString +bodyGatewayTimeout = "504 Gateway Timeout: upstream did not respond in time" + +bodyWebSocketUpgradeFailed :: LBS.ByteString +bodyWebSocketUpgradeFailed = "WebSocket upgrade failed" + +hopByHopRequestHeaders :: [HeaderName] +hopByHopRequestHeaders = + [ "Connection" + , "Keep-Alive" + , "Proxy-Authenticate" + , "Proxy-Authorization" + , "TE" + , "Trailers" + , "Transfer-Encoding" + , "Upgrade" + ] + +hopByHopResponseHeaders :: [HeaderName] +hopByHopResponseHeaders = + [ "Transfer-Encoding" + , "Connection" + , "Keep-Alive" + ] + +eventStreamContentType :: ByteString +eventStreamContentType = "text/event-stream" + +chunkedEncoding :: ByteString +chunkedEncoding = "chunked" + +httpScheme :: String +httpScheme = "http://" + data ProxyState = ProxyState - { psConfig :: Config - , psLoadBalancers :: Map Text LoadBalancer -- upstream name -> load balancer - , psHealthCheckers :: [Async ()] - , psManager :: Manager - , psRateLimiter :: Maybe RateLimiter - , psMemoryShed :: Maybe MemoryShed - , psIPJail :: Maybe IPJail - , psConnLimiter :: Maybe ConnLimiter - , psWafRuleSet :: TVar RuleSet - , psGeo :: Maybe Geo + { psConfig :: !Config + , psLoadBalancers :: !(Map Text LoadBalancer) + , psHealthCheckers :: ![Async ()] + , psManager :: !Manager + , psRateLimiter :: !(Maybe RateLimiter) + , psMemoryShed :: !(Maybe MemoryShed) + , psIPJail :: !(Maybe IPJail) + , psConnLimiter :: !(Maybe ConnLimiter) + , psWafRuleSet :: !(TVar RuleSet) + , psGeo :: !(Maybe Geo) } --- | Initialize proxy state from config initProxyState :: Config -> Manager -> IO ProxyState initProxyState config manager = do - -- Create load balancers for each upstream lbs <- mapM createUpstreamLoadBalancer (configUpstreams config) - let lbMap = Map.fromList (zip (map upstreamName $ configUpstreams config) lbs) + let lbMap = Map.fromList (zip (map upstreamName (configUpstreams config)) lbs) - -- Start health checkers for all upstreams checkers <- mapM startUpstreamHealthChecker (configUpstreams config) rateLimiter <- case configRateLimit config >>= parseRateSpec of @@ -142,8 +205,9 @@ initProxyState config manager = do ms <- newMemoryShed let cfg = MemoryShedConfig { mscHeapBudgetBytes = fromInteger budgetBytes - , mscHighWaterFraction = fromMaybe defaultHighWaterFraction (ddos >>= ddosMemoryShedHighWater) - , mscPollIntervalMicros = 1000000 + , mscHighWaterFraction = fromMaybe defaultHighWaterFraction + (ddos >>= ddosMemoryShedHighWater) + , mscPollIntervalMicros = memoryShedPollIntervalMicros } _ <- startMemoryShedPoller cfg ms pure (Just ms) @@ -170,57 +234,45 @@ initProxyState config manager = do Nothing -> pure Nothing return ProxyState - { psConfig = config - , psLoadBalancers = lbMap + { psConfig = config + , psLoadBalancers = lbMap , psHealthCheckers = checkers - , psManager = manager - , psRateLimiter = rateLimiter - , psMemoryShed = memShed - , psIPJail = ipJail - , psConnLimiter = connLimiter - , psWafRuleSet = wafVar - , psGeo = geoHandle + , psManager = manager + , psRateLimiter = rateLimiter + , psMemoryShed = memShed + , psIPJail = ipJail + , psConnLimiter = connLimiter + , psWafRuleSet = wafVar + , psGeo = geoHandle } where - -- Create load balancer for an upstream createUpstreamLoadBalancer :: Upstream -> IO LoadBalancer createUpstreamLoadBalancer upstream = do - -- Convert Config Servers to RuntimeBackends backends <- zipWithM createRuntimeBackend [0..] (upstreamServers upstream) - - -- Determine strategy (for now, use weighted if weights differ, else round-robin) let weights = map serverWeight (upstreamServers upstream) strategy = case weights of - [] -> RoundRobin -- No backends, shouldn't happen but be safe - (w:ws) -> if all (== w) ws - then RoundRobin - else WeightedRoundRobin - + [] -> RoundRobin + (w:ws) + | all (== w) ws -> RoundRobin + | otherwise -> WeightedRoundRobin createLoadBalancer strategy backends - -- Start health checker for an upstream startUpstreamHealthChecker :: Upstream -> IO (Async ()) startUpstreamHealthChecker upstream = do backends <- zipWithM createRuntimeBackend [0..] (upstreamServers upstream) - - -- Use health check config from upstream, or defaults let hcConfig = case upstreamHealthCheck upstream of Just hc -> defaultHealthCheckConfig - { hcInterval = 10 -- TODO: parse interval from config - , hcEndpoint = healthCheckPath hc + { hcEndpoint = healthCheckPath hc } Nothing -> defaultHealthCheckConfig - startHealthChecker manager hcConfig backends --- | Start the proxy server with given configuration --- Supports multiple ports with HTTP and HTTPS (including SNI) startProxy :: ProxyState -> IO () startProxy ProxyState{..} = do - putStrLn $ "Starting Ᾰenebris reverse proxy" - putStrLn $ "Loaded " ++ show (length $ configUpstreams psConfig) ++ " upstream(s)" - putStrLn $ "Loaded " ++ show (length $ configRoutes psConfig) ++ " route(s)" - putStrLn $ "Health checking enabled for all upstreams" + putStrLn "Starting Aenebris reverse proxy" + putStrLn $ "Loaded " ++ show (length (configUpstreams psConfig)) ++ " upstream(s)" + putStrLn $ "Loaded " ++ show (length (configRoutes psConfig)) ++ " route(s)" + putStrLn "Health checking enabled for all upstreams" case configListen psConfig of [] -> do @@ -228,28 +280,37 @@ startProxy ProxyState{..} = do exitFailure listenConfigs -> do case psRateLimiter of - Just _ -> putStrLn "Rate limiting enabled" + Just _ -> putStrLn "Rate limiting enabled" Nothing -> pure () putStrLn "WAF enabled (Phase 1: paranoia level 2, default rule pack)" case buildHoneypotConfig (configHoneypot psConfig) of - Just hp -> putStrLn $ "Honeypot enabled (" ++ show (length (hpPatterns hp)) - ++ " trap patterns, action=" ++ show (hpAction hp) ++ ")" + Just hp -> putStrLn $ + "Honeypot enabled (" + ++ show (length (hpPatterns hp)) + ++ " trap patterns, action=" + ++ show (hpAction hp) + ++ ")" Nothing -> pure () case psGeo of Just g -> let gc = geoConfig g - parts = [ "country_db=" ++ maybe "off" (const "on") (gcCountryDb gc) - , "asn_db=" ++ maybe "off" (const "on") (gcAsnDb gc) - , "blocked=" ++ show (length (gcBlockedCountries gc)) - , "flagged_asns=" ++ show (length (gcFlaggedAsns gc)) - ] + parts = + [ "country_db=" ++ maybe "off" (const "on") (gcCountryDb gc) + , "asn_db=" ++ maybe "off" (const "on") (gcAsnDb gc) + , "blocked=" ++ show (length (gcBlockedCountries gc)) + , "flagged_asns=" ++ show (length (gcFlaggedAsns gc)) + ] in putStrLn $ "Geo/ASN enabled (" ++ unwords parts ++ ")" Nothing -> pure () - servers <- mapM (launchServer psConfig psLoadBalancers psManager psRateLimiter psMemoryShed psIPJail psConnLimiter psWafRuleSet psGeo) listenConfigs + + servers <- mapM + (launchServer psConfig psLoadBalancers psManager + psRateLimiter psMemoryShed psIPJail + psConnLimiter psWafRuleSet psGeo) + listenConfigs _ <- waitAnyCancel servers - putStrLn "All servers stopped" launchServer @@ -264,265 +325,253 @@ launchServer -> Maybe Geo -> ListenConfig -> IO (Async ()) -launchServer config loadBalancers manager mRateLimiter mMemShed mIPJail mConnLim wafVar mGeo listenConfig = async $ do - let port = listenPort listenConfig - shouldRedirect = fromMaybe False (listenRedirectHTTPS listenConfig) - ddosCfg = fromMaybe defaultDDoSConfig (configDDoS config) +launchServer config loadBalancers manager mRateLimiter mMemShed mIPJail mConnLim wafVar mGeo listenConfig = + async $ do + let port = listenPort listenConfig + shouldRedirect = fromMaybe False (listenRedirectHTTPS listenConfig) + ddosCfg = fromMaybe defaultDDoSConfig (configDDoS config) - baseApp = proxyApp config loadBalancers manager + baseApp = proxyApp config loadBalancers manager + fingerprintedApp = ja4hMiddleware baseApp + wafApp = wafMiddleware wafVar fingerprintedApp + securedApp = addSecurityHeaders defaultSecurityConfig wafApp - fingerprintedApp = ja4hMiddleware baseApp + earlyDataApp = if ddosEarlyDataReject ddosCfg + then earlyDataGuard securedApp + else securedApp - wafApp = wafMiddleware wafVar fingerprintedApp + mHoneypotCfg = buildHoneypotConfig (configHoneypot config) + honeypotApp = case mHoneypotCfg of + Just hp -> honeypotMiddleware hp mIPJail earlyDataApp + Nothing -> earlyDataApp - securedApp = addSecurityHeaders defaultSecurityConfig wafApp + geoApp = case mGeo of + Just g -> geoMiddleware g mIPJail honeypotApp + Nothing -> honeypotApp - earlyDataApp = if ddosEarlyDataReject ddosCfg - then earlyDataGuard securedApp - else securedApp + jailedApp = case mIPJail of + Just j -> ipJailMiddleware j geoApp + Nothing -> geoApp - mHoneypotCfg = buildHoneypotConfig (configHoneypot config) + shedApp = case mMemShed of + Just ms -> memoryShedMiddleware ms jailedApp + Nothing -> jailedApp - honeypotApp = case mHoneypotCfg of - Just hp -> honeypotMiddleware hp mIPJail earlyDataApp - Nothing -> earlyDataApp + limitedApp = case mRateLimiter of + Just rl -> rateLimitMiddleware rl shedApp + Nothing -> shedApp - geoApp = case mGeo of - Just g -> geoMiddleware g mIPJail honeypotApp - Nothing -> honeypotApp + warpSettings = applyDDoSSettings ddosCfg mConnLim + (defaultSettings & setPort port) - jailedApp = case mIPJail of - Just j -> ipJailMiddleware j geoApp - Nothing -> geoApp + case listenTLS listenConfig of + Nothing -> do + let app = if shouldRedirect + then httpsRedirect limitedApp + else limitedApp + putStrLn $ "* HTTP server listening on :" ++ show port + if shouldRedirect + then putStrLn " Redirecting all traffic to HTTPS" + else pure () + runSettings warpSettings app - shedApp = case mMemShed of - Just ms -> memoryShedMiddleware ms jailedApp - Nothing -> jailedApp - - limitedApp = case mRateLimiter of - Just rl -> rateLimitMiddleware rl shedApp - Nothing -> shedApp - - warpSettings = applyDDoSSettings ddosCfg mConnLim (defaultSettings & setPort port) - - case listenTLS listenConfig of - Nothing -> do - let app = if shouldRedirect - then httpsRedirect limitedApp - else limitedApp - - putStrLn $ "✓ HTTP server listening on :" ++ show port - if shouldRedirect - then putStrLn $ " └─ Redirecting all traffic to HTTPS" - else return () - - runSettings warpSettings app - - Just tlsConfig -> do - let isSNI = case tlsSNI tlsConfig of - Just domains -> not (null domains) - Nothing -> False - - if isSNI - then launchHTTPSWithSNI port tlsConfig limitedApp - else launchHTTPS port tlsConfig limitedApp + Just tlsConfig -> do + let isSNI = case tlsSNI tlsConfig of + Just domains -> not (null domains) + Nothing -> False + if isSNI + then launchHTTPSWithSNI port tlsConfig limitedApp + else launchHTTPS port tlsConfig limitedApp applyDDoSSettings :: DDoSConfig -> Maybe ConnLimiter -> Settings -> Settings applyDDoSSettings ddos mConnLim s0 = - let s1 = case ddosMaxHeaderBytes ddos of - Just n -> setMaxTotalHeaderLength n s1Inner - Nothing -> s1Inner - s1Inner = case ddosSlowlorisSeconds ddos of - Just n -> setTimeout n s0 + let s1Inner = case ddosSlowlorisSeconds ddos of + Just n -> setTimeout n s0 Nothing -> s0 + s1 = case ddosMaxHeaderBytes ddos of + Just n -> setMaxTotalHeaderLength n s1Inner + Nothing -> s1Inner s2 = case mConnLim of - Just cl -> setOnClose (connLimitOnClose cl) (setOnOpen (connLimitOnOpen cl) s1) + Just cl -> setOnClose (connLimitOnClose cl) + (setOnOpen (connLimitOnOpen cl) s1) Nothing -> s1 in s2 --- | Launch HTTPS server with single certificate launchHTTPS :: Int -> TLSConfig -> Application -> IO () -launchHTTPS port tlsConfig app = do +launchHTTPS port tlsConfig app = case (tlsCert tlsConfig, tlsKey tlsConfig) of (Just certFile, Just keyFile) -> do - -- Load TLS settings tlsResult <- createTLSSettings certFile keyFile case tlsResult of Left err -> do hPutStrLn stderr "ERROR: Failed to load TLS certificate" hPutStrLn stderr $ " " ++ show err exitFailure - Right tlsSettings -> do let warpSettings = defaultSettings & setPort port - putStrLn $ "✓ HTTPS server listening on :" ++ show port - putStrLn $ " ├─ Certificate: " ++ certFile - putStrLn $ " ├─ TLS 1.2 + TLS 1.3 enabled" - putStrLn $ " ├─ HTTP/2 enabled (ALPN)" - putStrLn $ " └─ Strong cipher suites enforced" + putStrLn $ "* HTTPS server listening on :" ++ show port + putStrLn $ " Certificate: " ++ certFile + putStrLn " TLS 1.2 + TLS 1.3 enabled" + putStrLn " HTTP/2 enabled (ALPN)" + putStrLn " Strong cipher suites enforced" runTLS tlsSettings warpSettings app - _ -> do hPutStrLn stderr "ERROR: TLS configuration requires both cert and key" exitFailure --- | Launch HTTPS server with SNI support (multiple certificates) launchHTTPSWithSNI :: Int -> TLSConfig -> Application -> IO () -launchHTTPSWithSNI port tlsConfig app = do +launchHTTPSWithSNI port tlsConfig app = case (tlsSNI tlsConfig, tlsDefaultCert tlsConfig, tlsDefaultKey tlsConfig) of (Just sniDomains, Just defaultCert, Just defaultKey) -> do - -- Convert SNIDomain list to the format expected by createSNISettings let domainList = [(sniDomain d, sniCert d, sniKey d) | d <- sniDomains] - - -- Load SNI TLS settings tlsResult <- createSNISettings domainList defaultCert defaultKey case tlsResult of Left err -> do hPutStrLn stderr "ERROR: Failed to load SNI certificates" hPutStrLn stderr $ " " ++ show err exitFailure - Right tlsSettings -> do let warpSettings = defaultSettings & setPort port - putStrLn $ "✓ HTTPS server with SNI listening on :" ++ show port - putStrLn $ " ├─ SNI domains: " ++ show (length sniDomains) ++ " configured" - mapM_ (\d -> putStrLn $ " │ • " ++ T.unpack (sniDomain d) ++ " -> " ++ sniCert d) sniDomains - putStrLn $ " ├─ Default certificate: " ++ defaultCert - putStrLn $ " ├─ TLS 1.2 + TLS 1.3 enabled" - putStrLn $ " ├─ HTTP/2 enabled (ALPN)" - putStrLn $ " └─ Strong cipher suites enforced" + putStrLn $ "* HTTPS server with SNI listening on :" ++ show port + putStrLn $ " SNI domains: " ++ show (length sniDomains) ++ " configured" + mapM_ + (\d -> putStrLn $ + " " ++ T.unpack (sniDomain d) ++ " -> " ++ sniCert d) + sniDomains + putStrLn $ " Default certificate: " ++ defaultCert + putStrLn " TLS 1.2 + TLS 1.3 enabled" + putStrLn " HTTP/2 enabled (ALPN)" + putStrLn " Strong cipher suites enforced" runTLS tlsSettings warpSettings app - _ -> do - hPutStrLn stderr - "ERROR: SNI requires sni, default_cert, and default_key" + hPutStrLn stderr "ERROR: SNI requires sni, default_cert, and default_key" exitFailure --- | Main proxy application (WAI) proxyApp :: Config -> Map Text LoadBalancer -> Manager -> Application proxyApp config loadBalancers manager req respond = do - logRequest req - - let hostHeader = lookup "Host" (requestHeaders req) + let hostHeader = lookup "Host" (requestHeaders req) requestPath = rawPathInfo req - headers = requestHeaders req - connType = detectConnectionType headers + headers = requestHeaders req + connType = detectConnectionType headers case selectRoute config hostHeader requestPath of Nothing -> do - hPutStrLn stderr $ "ERROR: No route found for request" + hPutStrLn stderr "ERROR: No route found for request" respond $ responseLBS status404 - [("Content-Type", "text/plain")] - "Not Found: No route configured for this host/path" + [(hContentType, contentTypePlain)] + bodyNotFound - Just (upstreamName, _pathRoute) -> do + Just (upstreamName, _pathRoute) -> case Map.lookup upstreamName loadBalancers of Nothing -> do - hPutStrLn stderr $ "ERROR: Load balancer not found: " ++ T.unpack upstreamName + hPutStrLn stderr $ + "ERROR: Load balancer not found: " ++ T.unpack upstreamName respond $ responseLBS status500 - [("Content-Type", "text/plain")] - "Internal Server Error: Upstream configuration error" + [(hContentType, contentTypePlain)] + bodyUpstreamMisconfigured Just loadBalancer -> do mBackend <- selectBackend loadBalancer - case mBackend of Nothing -> do - hPutStrLn stderr $ "ERROR: No healthy backends available" + hPutStrLn stderr "ERROR: No healthy backends available" respond $ responseLBS status503 - [("Content-Type", "text/plain")] - "Service Unavailable: No healthy backends available" + [(hContentType, contentTypePlain)] + bodyNoHealthyBackends - Just backend -> do - case connType of - WebSocket -> do - hPutStrLn stderr $ "[WS] WebSocket upgrade detected" - handleWebSocketUpgrade req respond backend + Just backend -> case connType of + WebSocket -> do + hPutStrLn stderr "[WS] WebSocket upgrade detected" + handleWebSocketUpgrade req respond backend + _ -> + forwardRegular manager backend req respond - RegularHttp -> do - result <- try $ trackConnection backend $ - forwardRequest manager req (rbHost backend) respond +forwardRegular + :: Manager + -> RuntimeBackend + -> Request + -> (Response -> IO ResponseReceived) + -> IO ResponseReceived +forwardRegular manager backend req respond = do + result <- try $ trackConnection backend $ + forwardRequest manager req (rbHost backend) respond + case result of + Left (err :: SomeException) -> do + hPutStrLn stderr $ "ERROR: " ++ show err + respond $ responseLBS + status502 + [(hContentType, contentTypePlain)] + bodyBadGateway + Right responseReceived -> + pure responseReceived - case result of - Left (err :: SomeException) -> do - hPutStrLn stderr $ "ERROR: " ++ show err - respond $ responseLBS - status502 - [("Content-Type", "text/plain")] - "Bad Gateway: Could not connect to backend server" - - Right responseReceived -> - return responseReceived - - _ -> do - result <- try $ trackConnection backend $ - forwardRequest manager req (rbHost backend) respond - - case result of - Left (err :: SomeException) -> do - hPutStrLn stderr $ "ERROR: " ++ show err - respond $ responseLBS - status502 - [("Content-Type", "text/plain")] - "Bad Gateway: Could not connect to backend server" - - Right responseReceived -> - return responseReceived - -handleWebSocketUpgrade :: Request -> (Response -> IO ResponseReceived) -> RuntimeBackend -> IO ResponseReceived +handleWebSocketUpgrade + :: Request + -> (Response -> IO ResponseReceived) + -> RuntimeBackend + -> IO ResponseReceived handleWebSocketUpgrade req respond backend = do let backendHost = rbHost backend backupResponse = responseLBS status502 - [("Content-Type", "text/plain")] - "WebSocket upgrade failed" - + [(hContentType, contentTypePlain)] + bodyWebSocketUpgradeFailed respond $ responseRaw (wsHandler req backendHost) backupResponse -wsHandler :: Request -> Text -> IO ByteString -> (ByteString -> IO ()) -> IO () +wsHandler + :: Request + -> Text + -> IO ByteString + -> (ByteString -> IO ()) + -> IO () wsHandler req backendHost recv send = do hPutStrLn stderr $ "[WS] Starting WebSocket tunnel to " ++ T.unpack backendHost tunnelWebSocket req backendHost send recv --- | Select a route based on Host header and path -selectRoute :: Config -> Maybe BS.ByteString -> BS.ByteString -> Maybe (Text, PathRoute) -selectRoute config hostHeader requestPath = - case hostHeader of - Nothing -> Nothing -- No Host header, can't route - Just host -> do - -- Find route matching this host - let hostText = TE.decodeUtf8 host - matchingRoutes = filter (\r -> routeHost r == hostText) (configRoutes config) +selectRoute + :: Config + -> Maybe BS.ByteString + -> BS.ByteString + -> Maybe (Text, PathRoute) +selectRoute config hostHeader requestPath = case hostHeader of + Nothing -> Nothing + Just host -> do + let hostText = TE.decodeUtf8 host + matchingRoutes = filter (\r -> routeHost r == hostText) + (configRoutes config) + route <- listToMaybe matchingRoutes + let requestPathText = TE.decodeUtf8 requestPath + sortedPaths = sortBy + (comparing (negate . T.length . pathRoutePath)) + (routePaths route) + matchingPaths = filter + (\p -> pathMatches (pathRoutePath p) requestPathText) + sortedPaths + pathRoute <- listToMaybe matchingPaths + return (pathRouteUpstream pathRoute, pathRoute) - -- Find first matching path within the route - route <- listToMaybe matchingRoutes - let requestPathText = TE.decodeUtf8 requestPath - -- Sort paths by length (longest first) so more specific paths match first - sortedPaths = sortBy (comparing (negate . T.length . pathRoutePath)) (routePaths route) - matchingPaths = filter (\p -> pathMatches (pathRoutePath p) requestPathText) sortedPaths - - pathRoute <- listToMaybe matchingPaths - return (pathRouteUpstream pathRoute, pathRoute) - --- | Check if a path pattern matches a request path pathMatches :: Text -> Text -> Bool pathMatches pattern requestPath = pattern == "/" || T.isPrefixOf pattern requestPath --- | Select an upstream for a request (exported for testing) -selectUpstream :: Config -> Maybe BS.ByteString -> BS.ByteString -> Maybe Text +selectUpstream + :: Config -> Maybe BS.ByteString -> BS.ByteString -> Maybe Text selectUpstream config hostHeader requestPath = - fmap fst $ selectRoute config hostHeader requestPath + fst <$> selectRoute config hostHeader requestPath --- | Forward request to backend server with streaming support -forwardRequest :: Manager -> Request -> Text -> (Response -> IO ResponseReceived) -> IO ResponseReceived +forwardRequest + :: Manager + -> Request + -> Text + -> (Response -> IO ResponseReceived) + -> IO ResponseReceived forwardRequest manager clientReq backendHost respond = do - let backendUrl = "http://" ++ T.unpack backendHost ++ - BS8.unpack (rawPathInfo clientReq) ++ - BS8.unpack (rawQueryString clientReq) + let backendUrl = httpScheme ++ T.unpack backendHost + ++ BS8.unpack (rawPathInfo clientReq) + ++ BS8.unpack (rawQueryString clientReq) initReq <- parseRequest backendUrl @@ -536,56 +585,53 @@ forwardRequest manager clientReq backendHost respond = do backendReq = initReq { HTTP.method = requestMethod clientReq - , HTTP.requestHeaders = filterHeaders (requestHeaders clientReq) + , HTTP.requestHeaders = filterRequestHeaders (requestHeaders clientReq) , HTTP.requestBody = streamingBody } - let upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig + upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig * microsPerSecond + mResult <- timeout upstreamMicros $ withResponse backendReq manager $ \backendResponse -> do - let status = HTTP.responseStatus backendResponse - headers = HTTP.responseHeaders backendResponse + let status = HTTP.responseStatus backendResponse + headers = HTTP.responseHeaders backendResponse bodyReader = HTTP.responseBody backendResponse - if shouldStreamResponse headers then do hPutStrLn stderr "[STREAM] Streaming response detected" - respond $ responseStream status (filterResponseHeaders headers) $ \write flush -> do - let loop = do - chunk <- brRead bodyReader - unless (BS.null chunk) $ do - write (byteString chunk) - flush - loop - loop + respond $ responseStream status (filterResponseHeaders headers) $ + \write flush -> do + let loop = do + chunk <- brRead bodyReader + unless (BS.null chunk) $ do + write (byteString chunk) + flush + loop + loop else do body <- readFullBody bodyReader respond $ responseLBS status (filterResponseHeaders headers) body + case mResult of - Just rr -> return rr + Just rr -> pure rr Nothing -> respond $ responseLBS status504 - [("Content-Type", "text/plain")] - "504 Gateway Timeout: upstream did not respond in time" + [(hContentType, contentTypePlain)] + bodyGatewayTimeout shouldStreamResponse :: [(HeaderName, BS.ByteString)] -> Bool -shouldStreamResponse headers = - isSSE || isChunkedWithoutLength +shouldStreamResponse headers = isSSE || isChunkedWithoutLength where isSSE = case lookup "Content-Type" headers of - Just ct -> "text/event-stream" `BS.isInfixOf` ct + Just ct -> eventStreamContentType `BS.isInfixOf` ct Nothing -> False - - isChunkedWithoutLength = - hasChunkedEncoding && not hasContentLength - + isChunkedWithoutLength = hasChunkedEncoding && not hasContentLength hasChunkedEncoding = case lookup "Transfer-Encoding" headers of - Just te -> "chunked" `BS.isInfixOf` te + Just te -> chunkedEncoding `BS.isInfixOf` te Nothing -> False - hasContentLength = case lookup "Content-Length" headers of - Just _ -> True + Just _ -> True Nothing -> False readFullBody :: HTTP.BodyReader -> IO LBS.ByteString @@ -594,45 +640,17 @@ readFullBody bodyReader = LBS.fromChunks <$> go go = do chunk <- brRead bodyReader if BS.null chunk - then return [] + then pure [] else do rest <- go - return (chunk : rest) + pure (chunk : rest) -filterResponseHeaders :: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)] -filterResponseHeaders = filter (\(name, _) -> name `notElem` hopByHopHeaders) - where - hopByHopHeaders = - [ "Transfer-Encoding" - , "Connection" - , "Keep-Alive" - ] +filterResponseHeaders + :: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)] +filterResponseHeaders = + filter (\(name, _) -> name `notElem` hopByHopResponseHeaders) --- | Filter headers for regular HTTP (remove hop-by-hop headers) -filterHeaders :: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)] -filterHeaders headers = filter (\(name, _) -> name `notElem` hopByHopHeaders) headers - where - hopByHopHeaders = - [ "Connection" - , "Keep-Alive" - , "Proxy-Authenticate" - , "Proxy-Authorization" - , "TE" - , "Trailers" - , "Transfer-Encoding" - , "Upgrade" - ] - --- | Log incoming request -logRequest :: Request -> IO () -logRequest req = do - let method' = BS8.unpack (requestMethod req) - path = BS8.unpack (rawPathInfo req) - query = BS8.unpack (rawQueryString req) - host = fromMaybe "unknown" $ lookup "Host" (requestHeaders req) - - putStrLn $ "[→] " ++ method' ++ " " ++ path ++ query ++ " (Host: " ++ BS8.unpack host ++ ")" - --- Helper: zipWithM -zipWithM :: Monad m => (a -> b -> m c) -> [a] -> [b] -> m [c] -zipWithM f xs ys = sequence (zipWith f xs ys) +filterRequestHeaders + :: [(HeaderName, BS.ByteString)] -> [(HeaderName, BS.ByteString)] +filterRequestHeaders = + filter (\(name, _) -> name `notElem` hopByHopRequestHeaders) diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/RateLimit.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/RateLimit.hs index 6f125c4a..4963c805 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/RateLimit.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/RateLimit.hs @@ -31,6 +31,7 @@ import Control.Concurrent.STM ) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 +import Data.List (intercalate) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text) @@ -175,12 +176,7 @@ clientIPKey req = case remoteHost req of v6Bytes ha = let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple ha parts = [a, b, c, d, e, f, g, h] - in BS8.pack (joinColons (map (`showHex` "") parts)) - - joinColons :: [String] -> String - joinColons [] = "" - joinColons [x] = x - joinColons (x : xs) = x <> ":" <> joinColons xs + in BS8.pack (intercalate ":" (map (`showHex` "") parts)) pathClassKey :: Request -> ByteString pathClassKey req = diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Engine.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Engine.hs index 0bd0fe5f..17eff80b 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Engine.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Engine.hs @@ -39,7 +39,7 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.Char (toLower) import Data.Word (Word32) -import Network.HTTP.Types (Status, mkStatus) +import Network.HTTP.Types (status403) import Network.HTTP.Types.URI (urlDecode) import Network.Wai ( Middleware @@ -159,9 +159,6 @@ decisionFromScore hasBlock score threshold matches wafResponseHeader :: CI ByteString wafResponseHeader = "x-aenebris-waf" -status403 :: Status -status403 = mkStatus 403 "Forbidden" - wafMiddleware :: TVar RuleSet -> Middleware wafMiddleware rsVar app req respond = do rs <- readTVarIO rsVar diff --git a/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs b/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs index d0914406..954a642d 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs @@ -10,10 +10,13 @@ import Aenebris.Backend ( createRuntimeBackend , getConnectionCount , isHealthy + , rbActiveConnections + , rbConsecutiveFailures , rbServerId , rbWeight , recordFailure , recordSuccess + , trackConnection , transitionToHealthy , transitionToRecovering , transitionToUnhealthy @@ -30,7 +33,8 @@ import Aenebris.Config , validateConfig ) import Aenebris.DDoS.ConnLimit - ( defaultConnLimitConfig + ( currentCount + , defaultConnLimitConfig , defaultPerIPLimit , ipBytesFromSockAddr , newConnLimiter @@ -262,6 +266,7 @@ import Control.Concurrent.STM ( atomically , modifyTVar' , newTVarIO + , readTVar , readTVarIO ) import qualified Data.ByteString as BS @@ -477,31 +482,46 @@ loadBalancerSpec = describe "LoadBalancer" $ do lb <- createLoadBalancer RoundRobin [] selectBackend lb `shouldReturn` Nothing - it "selects from backend pool with round robin" $ do + it "round robin distributes evenly across the pool" $ do bks <- mapM (\(i, h) -> createRuntimeBackend i (Server h 1)) [(0, "host-a:80"), (1, "host-b:80"), (2, "host-c:80")] lb <- createLoadBalancer RoundRobin bks - let getName = fmap (fmap rbServerId) (selectBackend lb) - a <- getName - b <- getName - c <- getName - isJust a `shouldBe` True - isJust b `shouldBe` True - isJust c `shouldBe` True + let totalRounds = 9 :: Int + selections <- mapM + (\_ -> fmap (fmap rbServerId) (selectBackend lb)) + [1 .. totalRounds] + let counts = + [ length (filter (== Just sid) selections) + | sid <- [0, 1, 2] + ] + counts `shouldBe` [3, 3, 3] - it "selects backend with weighted round robin" $ do + it "weighted round robin selects proportionally" $ do bks <- mapM (\(i, h, w) -> createRuntimeBackend i (Server h w)) [(0, "host-a:80", 1), (1, "host-b:80", 4)] lb <- createLoadBalancer WeightedRoundRobin bks - selected <- selectBackend lb - isJust selected `shouldBe` True + let totalRounds = 50 :: Int + selections <- mapM + (\_ -> fmap (fmap rbServerId) (selectBackend lb)) + [1 .. totalRounds] + let countA = length (filter (== Just 0) selections) + countB = length (filter (== Just 1) selections) + countB `shouldSatisfy` (>= 35) + countA `shouldSatisfy` (<= 15) - it "selects least connections backend" $ do + it "least connections picks the backend with fewest active connections" $ do bks <- mapM (\(i, h) -> createRuntimeBackend i (Server h 1)) [(0, "host-a:80"), (1, "host-b:80")] - lb <- createLoadBalancer LeastConnections bks - selected <- selectBackend lb - isJust selected `shouldBe` True + case bks of + [a, _b] -> do + atomically $ + modifyTVar' + (rbActiveConnections a) + (+ 5) + lb <- createLoadBalancer LeastConnections bks + selected <- selectBackend lb + fmap rbServerId selected `shouldBe` Just 1 + _ -> expectationFailure "expected exactly two backends" backendSpec :: Spec backendSpec = describe "Backend" $ do @@ -526,17 +546,21 @@ backendSpec = describe "Backend" $ do bk <- createRuntimeBackend 0 (Server "host:80" 1) atomically (getConnectionCount bk) `shouldReturn` 0 - it "tolerates repeated failures" $ do + it "transitions to Unhealthy after maxFailures consecutive failures" $ do bk <- createRuntimeBackend 0 (Server "host:80" 10) - atomically $ recordFailure bk 3 - atomically $ recordFailure bk 3 - atomically $ recordFailure bk 3 - rbWeight bk `shouldBe` 10 + atomically (recordFailure bk 3) + atomically (isHealthy bk) `shouldReturn` True + atomically (recordFailure bk 3) + atomically (isHealthy bk) `shouldReturn` True + atomically (recordFailure bk 3) + atomically (isHealthy bk) `shouldReturn` False - it "records successes without crashing" $ do + it "recordSuccess on Healthy resets the failure counter" $ do bk <- createRuntimeBackend 0 (Server "host:80" 5) - atomically $ recordSuccess bk 5 - pure () + atomically (recordFailure bk 5) + atomically (readTVar (rbConsecutiveFailures bk)) `shouldReturn` 1 + atomically (recordSuccess bk 5) + atomically (readTVar (rbConsecutiveFailures bk)) `shouldReturn` 0 securitySpec :: Spec securitySpec = describe "Security headers" $ do @@ -752,11 +776,12 @@ connLimitSpec = describe "ConnLimit" $ do res <- atomically (tryAcquire cl "9.9.9.9") res `shouldBe` False - it "release decrements counter" $ do + it "release decrements counter back to 0" $ do cl <- newConnLimiter defaultConnLimitConfig _ <- atomically (tryAcquire cl "1.2.3.4") + atomically (currentCount cl "1.2.3.4") `shouldReturn` 1 atomically (release cl "1.2.3.4") - pure () + atomically (currentCount cl "1.2.3.4") `shouldReturn` 0 ja4hSpec :: Spec ja4hSpec = describe "JA4H fingerprint" $ do From d9dd59db2a42d46afda3daa66337d6d47aaa9141 Mon Sep 17 00:00:00 2001 From: CarterPerez-dev Date: Wed, 29 Apr 2026 02:15:14 -0400 Subject: [PATCH 4/5] fix: close audit-pass-1 remaining MAJOR + quick MINOR (Findings 14, 19, 20, 28, 29) - Geo.hs (Finding 14): geoAsnCounts is now bounded by defaultGeoAsnCountCap = 200_000. capAsnCounts is called inside bumpAsnCounter; on overflow, the entry with the oldest awWindowStart is evicted via Data.List.minimumBy + Data.Ord.comparing. Closes the unbounded-Map memory growth path. Uses minimumBy and comparing imports added to the existing module. - ML/Middleware.hs, WAF/Engine.hs, Honeypot.hs (Finding 19): em dashes (\x2014) in user-facing response bodies and the generated robots.txt comment replaced with ASCII hyphens, per the project's guardrail-safe terminology rule. - aenebris.cabal (Finding 20): copyright field updated from '2025 Carter Perez' to '2026 AngelaMos' to match the file headers. - ML/IForest.hs (Finding 28): pathLength now respects a hard maxIForestDepth = 64 cutoff. Beyond that depth the function returns currentDepth + c(1) (= currentDepth) without further recursion, so a pathological tree built by a buggy fitter cannot blow the stack. Standard iForest depth is ceil(log2(256)) = 8, so the cap leaves >>8 generous headroom. - ML/Model.hs (Finding 29): validateCategoricalNode now also rejects categorical thresholds that are not whole numbers. A threshold of 1.5 would silently floor to 1 today; with this change it is reported as a clear validation error instead. Real LightGBM never writes non-integer cat indices, so this is defense-in-depth against malformed exporters. Build clean, 358 examples passing, 0 failures. --- .../haskell-reverse-proxy/aenebris.cabal | 2 +- .../haskell-reverse-proxy/src/Aenebris/Geo.hs | 18 ++++++++++++- .../src/Aenebris/Honeypot.hs | 2 +- .../src/Aenebris/ML/IForest.hs | 26 +++++++++++++------ .../src/Aenebris/ML/Middleware.hs | 2 +- .../src/Aenebris/ML/Model.hs | 18 ++++++++----- .../src/Aenebris/WAF/Engine.hs | 2 +- 7 files changed, 50 insertions(+), 20 deletions(-) diff --git a/PROJECTS/advanced/haskell-reverse-proxy/aenebris.cabal b/PROJECTS/advanced/haskell-reverse-proxy/aenebris.cabal index a95ad7bd..eac26e1f 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/aenebris.cabal +++ b/PROJECTS/advanced/haskell-reverse-proxy/aenebris.cabal @@ -9,7 +9,7 @@ license: MIT license-file: LICENSE author: Carter Perez maintainer: support@certgames.com -copyright: 2025 Carter Perez +copyright: 2026 AngelaMos category: Network, Security, Web build-type: Simple extra-source-files: README.md diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Geo.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Geo.hs index 93567003..774af8fe 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Geo.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Geo.hs @@ -60,9 +60,11 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as LBS import Data.GeoIP2 (GeoDB, GeoResult(..), AS(..), findGeoData, openGeoDB) import Data.IP (IP(..), fromHostAddress, fromHostAddress6) +import Data.List (minimumBy) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isJust) +import Data.Ord (comparing) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -95,6 +97,9 @@ defaultGeoSweepIntervalMicros = 60_000_000 defaultGeoFlaggedAsns :: [Int] defaultGeoFlaggedAsns = [] +defaultGeoAsnCountCap :: Int +defaultGeoAsnCountCap = 200_000 + geoResponseHeaderName :: HeaderName geoResponseHeaderName = "x-aenebris-geo" @@ -262,9 +267,20 @@ bumpAsnCounter Geo{..} n now = do | now - awWindowStart w < window -> w { awCount = awCount w + 1 } _ -> AsnWindow { awCount = 1, awWindowStart = now } - writeTVar geoAsnCounts $! Map.insert n entry m + inserted = Map.insert n entry m + bounded = capAsnCounts inserted + writeTVar geoAsnCounts $! bounded pure (awCount entry) +capAsnCounts :: Map Int AsnWindow -> Map Int AsnWindow +capAsnCounts m + | Map.size m <= defaultGeoAsnCountCap = m + | otherwise = + let oldestKey = fst $ minimumBy + (comparing (awWindowStart . snd)) + (Map.toList m) + in Map.delete oldestKey m + asnConcentrationScore :: Geo -> Int -> Double asnConcentrationScore Geo{..} count = let threshold = max 1 (gcConcentrationThreshold geoConfig) diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Honeypot.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Honeypot.hs index 0e819b4f..6e0fbabb 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Honeypot.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Honeypot.hs @@ -274,7 +274,7 @@ robotsResponse cfg = robotsTxtBody :: HoneypotConfig -> ByteString robotsTxtBody HoneypotConfig{..} = BS.concat $ [ "User-agent: *\n" - , "# Honeypot trap paths — Disallow per RFC 9309. Visiting these\n" + , "# Honeypot trap paths. Disallow per RFC 9309. Visiting these\n" , "# paths is treated as a violation signal regardless of declared UA.\n" ] <> map disallowLine hpPatterns where diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/IForest.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/IForest.hs index 8515c15a..188884bd 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/IForest.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/IForest.hs @@ -16,6 +16,7 @@ module Aenebris.ML.IForest , minSubsampleForNormalization , defaultIForestNumTrees , defaultIForestSubsampleSize + , maxIForestDepth ) where import Data.Vector (Vector) @@ -44,6 +45,12 @@ defaultIForestNumTrees = 100 defaultIForestSubsampleSize :: Int defaultIForestSubsampleSize = 256 +maxIForestDepth :: Int +maxIForestDepth = 64 + +depthBoundLeafSize :: Int +depthBoundLeafSize = 1 + data ITree = ITreeLeaf !Int | ITreeSplit !Int !Double !ITree !ITree @@ -77,14 +84,17 @@ averagePathLength !trees !fv = addPath !acc !tree = acc + pathLength tree fv initialDepth pathLength :: ITree -> VU.Vector Double -> Int -> Double -pathLength !tree !fv !currentDepth = case tree of - ITreeLeaf !size -> - fromIntegral currentDepth + normalizationConstant size - ITreeSplit !featIdx !thr !left !right -> - let !fval = fv VU.! featIdx - in if fval <= thr - then pathLength left fv (currentDepth + 1) - else pathLength right fv (currentDepth + 1) +pathLength !tree !fv !currentDepth + | currentDepth >= maxIForestDepth = + fromIntegral currentDepth + normalizationConstant depthBoundLeafSize + | otherwise = case tree of + ITreeLeaf !size -> + fromIntegral currentDepth + normalizationConstant size + ITreeSplit !featIdx !thr !left !right -> + let !fval = fv VU.! featIdx + in if fval <= thr + then pathLength left fv (currentDepth + 1) + else pathLength right fv (currentDepth + 1) normalizationConstant :: Int -> Double normalizationConstant n diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Middleware.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Middleware.hs index 1433542f..eb99af13 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Middleware.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Middleware.hs @@ -54,7 +54,7 @@ challengeWireText :: ByteString challengeWireText = "challenge" botBlockBody :: LBS.ByteString -botBlockBody = "403 Forbidden \x2014 request blocked by Aenebris ML" +botBlockBody = "403 Forbidden - request blocked by Aenebris ML" challengePageBody :: LBS.ByteString challengePageBody = diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Model.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Model.hs index b2faa917..b9f90837 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Model.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/ML/Model.hs @@ -329,15 +329,19 @@ validateCategoricalNode :: Int -> Int -> Tree -> Int -> Int -> Int -> Int -> Either String () validateCategoricalNode featureCount nodeCount t i fIdx lIdx rIdx = do validateSplitNode featureCount nodeCount i fIdx lIdx rIdx - let catIdx = floor (treeThreshold t VU.! i) :: Int - nBound = VU.length (treeCatBoundaries t) - if nBound < 2 + let rawThreshold = treeThreshold t VU.! i + catIdx = floor rawThreshold :: Int + nBound = VU.length (treeCatBoundaries t) + if fromIntegral catIdx /= rawThreshold then Left ("Categorical node " <> show i - <> " requires non-empty cat_boundaries") - else if catIdx < 0 || catIdx >= nBound - 1 + <> " has non-integer threshold " <> show rawThreshold) + else if nBound < 2 then Left ("Categorical node " <> show i - <> " has out-of-range bitmap slice index " <> show catIdx) - else Right () + <> " requires non-empty cat_boundaries") + else if catIdx < 0 || catIdx >= nBound - 1 + then Left ("Categorical node " <> show i + <> " has out-of-range bitmap slice index " <> show catIdx) + else Right () validateEnsemble :: Int -> Ensemble -> Either String () validateEnsemble expectedFeatures ens = do diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Engine.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Engine.hs index 17eff80b..301f8c07 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Engine.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/WAF/Engine.hs @@ -170,4 +170,4 @@ wafMiddleware rsVar app req respond = do [ ("Content-Type", "text/plain; charset=utf-8") , (wafResponseHeader, "blocked score=" <> BC.pack (show score)) ] - "403 Forbidden — request blocked by Aenebris WAF" + "403 Forbidden - request blocked by Aenebris WAF" From 15f795f10cabd381969e06359bf7f3922af8982d Mon Sep 17 00:00:00 2001 From: CarterPerez-dev Date: Wed, 29 Apr 2026 02:19:56 -0400 Subject: [PATCH 5/5] fix: extract Aenebris.Net.IP to dedupe SockAddr rendering (Finding 10) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - New module src/Aenebris/Net/IP.hs exposes sockAddrToIPBytes :: SockAddr -> ByteString. Single canonical implementation for IPv4 dotted-decimal, IPv6 colon-hex (8 groups), and unix-socket "unix:" rendering. - Aenebris.RateLimit.clientIPKey reduces to `sockAddrToIPBytes . remoteHost`. Removes the local v6Bytes, the hostAddressToTuple/hostAddress6ToTuple/printf/showHex/ intercalate imports, and the duplicated implementation. - Aenebris.DDoS.ConnLimit drops its private copy of the same function. ipBytesFromSockAddr is kept as a thin alias for test backward-compatibility (= sockAddrToIPBytes), so existing callers and the connLimitSpec test continue to compile without rename churn. - aenebris.cabal: expose Aenebris.Net.IP in the library stanza (now 30 modules total). - test/Spec.hs: new netIpSpec asserts IPv4 dotted decimal, loopback, unix-socket prefix, and IPv6 colon-separated rendering (8 groups → 7 colons). Wires netIpSpec into main right after geoSpec. 362 examples passing, 0 failures, 0 GHC warnings. --- .../haskell-reverse-proxy/aenebris.cabal | 1 + .../src/Aenebris/DDoS/ConnLimit.hs | 27 +++--------- .../src/Aenebris/Net/IP.hs | 43 +++++++++++++++++++ .../src/Aenebris/RateLimit.hs | 23 +--------- .../haskell-reverse-proxy/test/Spec.hs | 23 ++++++++++ 5 files changed, 74 insertions(+), 43 deletions(-) create mode 100644 PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Net/IP.hs diff --git a/PROJECTS/advanced/haskell-reverse-proxy/aenebris.cabal b/PROJECTS/advanced/haskell-reverse-proxy/aenebris.cabal index eac26e1f..7cf66dd6 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/aenebris.cabal +++ b/PROJECTS/advanced/haskell-reverse-proxy/aenebris.cabal @@ -38,6 +38,7 @@ library , Aenebris.WAF.Engine , Aenebris.Honeypot , Aenebris.Geo + , Aenebris.Net.IP , Aenebris.ML.Features , Aenebris.ML.Model , Aenebris.ML.Loader diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/DDoS/ConnLimit.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/DDoS/ConnLimit.hs index a5d302ee..e570e946 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/DDoS/ConnLimit.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/DDoS/ConnLimit.hs @@ -28,19 +28,11 @@ import Control.Concurrent.STM , readTVar , writeTVar ) +import Aenebris.Net.IP (sockAddrToIPBytes) import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS8 -import Data.List (intercalate) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map -import Network.Socket - ( HostAddress6 - , SockAddr(..) - , hostAddress6ToTuple - , hostAddressToTuple - ) -import Numeric (showHex) -import Text.Printf (printf) +import Network.Socket (SockAddr) defaultPerIPLimit :: Int defaultPerIPLimit = 16 @@ -87,19 +79,10 @@ currentCount ConnLimiter{..} ip = do pure (Map.findWithDefault 0 ip m) connLimitOnOpen :: ConnLimiter -> SockAddr -> IO Bool -connLimitOnOpen cl sa = atomically (tryAcquire cl (ipBytesFromSockAddr sa)) +connLimitOnOpen cl sa = atomically (tryAcquire cl (sockAddrToIPBytes sa)) connLimitOnClose :: ConnLimiter -> SockAddr -> IO () -connLimitOnClose cl sa = atomically (release cl (ipBytesFromSockAddr sa)) +connLimitOnClose cl sa = atomically (release cl (sockAddrToIPBytes sa)) ipBytesFromSockAddr :: SockAddr -> ByteString -ipBytesFromSockAddr (SockAddrInet _ ha) = - let (a, b, c, d) = hostAddressToTuple ha - in BS8.pack (printf "%d.%d.%d.%d" a b c d) -ipBytesFromSockAddr (SockAddrInet6 _ _ ha6 _) = v6Bytes ha6 -ipBytesFromSockAddr (SockAddrUnix p) = BS8.pack ("unix:" <> p) - -v6Bytes :: HostAddress6 -> ByteString -v6Bytes ha = - let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple ha - in BS8.pack (intercalate ":" (map (`showHex` "") [a, b, c, d, e, f, g, h])) +ipBytesFromSockAddr = sockAddrToIPBytes diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Net/IP.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Net/IP.hs new file mode 100644 index 00000000..8033b209 --- /dev/null +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/Net/IP.hs @@ -0,0 +1,43 @@ +{- +©AngelaMos | 2026 +IP.hs +-} +{-# LANGUAGE OverloadedStrings #-} + +module Aenebris.Net.IP + ( sockAddrToIPBytes + ) where + +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS8 +import Data.List (intercalate) +import Network.Socket + ( HostAddress6 + , SockAddr(..) + , hostAddress6ToTuple + , hostAddressToTuple + ) +import Numeric (showHex) +import Text.Printf (printf) + +ipv4Format :: String +ipv4Format = "%d.%d.%d.%d" + +ipv6Separator :: String +ipv6Separator = ":" + +unixSocketPrefix :: String +unixSocketPrefix = "unix:" + +sockAddrToIPBytes :: SockAddr -> ByteString +sockAddrToIPBytes (SockAddrInet _ ha) = + let (a, b, c, d) = hostAddressToTuple ha + in BS8.pack (printf ipv4Format a b c d) +sockAddrToIPBytes (SockAddrInet6 _ _ ha6 _) = renderIPv6 ha6 +sockAddrToIPBytes (SockAddrUnix p) = BS8.pack (unixSocketPrefix <> p) + +renderIPv6 :: HostAddress6 -> ByteString +renderIPv6 ha = + let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple ha + parts = [a, b, c, d, e, f, g, h] + in BS8.pack (intercalate ipv6Separator (map (`showHex` "") parts)) diff --git a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/RateLimit.hs b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/RateLimit.hs index 4963c805..5e70cc58 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/RateLimit.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/RateLimit.hs @@ -29,9 +29,9 @@ import Control.Concurrent.STM , readTVar , writeTVar ) +import Aenebris.Net.IP (sockAddrToIPBytes) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 -import Data.List (intercalate) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text) @@ -39,12 +39,6 @@ import qualified Data.Text as T import qualified Data.Text.Read as TR import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import Network.HTTP.Types (status429) -import Network.Socket - ( HostAddress6 - , SockAddr(..) - , hostAddress6ToTuple - , hostAddressToTuple - ) import Network.Wai ( Middleware , Request @@ -52,8 +46,6 @@ import Network.Wai , remoteHost , responseLBS ) -import Numeric (showHex) -import Text.Printf (printf) secondsPerMinute :: Double secondsPerMinute = 60 @@ -165,18 +157,7 @@ rateLimitMiddleware rl app req respond = do intBS n = BS8.pack (show n) clientIPKey :: Request -> ByteString -clientIPKey req = case remoteHost req of - SockAddrInet _ ha -> - let (a, b, c, d) = hostAddressToTuple ha - in BS8.pack (printf "%d.%d.%d.%d" a b c d) - SockAddrInet6 _ _ ha6 _ -> v6Bytes ha6 - SockAddrUnix p -> BS8.pack ("unix:" <> p) - where - v6Bytes :: HostAddress6 -> ByteString - v6Bytes ha = - let (a, b, c, d, e, f, g, h) = hostAddress6ToTuple ha - parts = [a, b, c, d, e, f, g, h] - in BS8.pack (intercalate ":" (map (`showHex` "") parts)) +clientIPKey = sockAddrToIPBytes . remoteHost pathClassKey :: Request -> ByteString pathClassKey req = diff --git a/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs b/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs index 954a642d..9626e28c 100644 --- a/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs +++ b/PROJECTS/advanced/haskell-reverse-proxy/test/Spec.hs @@ -231,6 +231,7 @@ import Aenebris.ML.Loader ( ParseError(..) , parseEnsemble ) +import Aenebris.Net.IP (sockAddrToIPBytes) import Aenebris.Middleware.Redirect (httpsRedirect, httpsRedirectWithPort) import Aenebris.Middleware.Security ( addSecurityHeaders @@ -380,6 +381,7 @@ main = hspec $ do wafSpec honeypotSpec geoSpec + netIpSpec mlFeaturesSpec mlModelSpec mlLoaderSpec @@ -1883,6 +1885,27 @@ mlModelSpec = describe "ML.Model" $ do validateTree 20 bad `shouldSatisfy` (\r -> case r of { Left _ -> True; Right _ -> False }) +netIpSpec :: Spec +netIpSpec = describe "Net.IP" $ do + it "renders ipv4 sockaddr in dotted decimal" $ + sockAddrToIPBytes (ipv4Addr (10, 0, 0, 1) 1234) `shouldBe` "10.0.0.1" + + it "renders ipv4 loopback" $ + sockAddrToIPBytes (ipv4Addr (127, 0, 0, 1) 8080) `shouldBe` "127.0.0.1" + + it "renders unix sockaddr with prefix" $ + sockAddrToIPBytes (SockAddrUnix "/tmp/sock") `shouldBe` "unix:/tmp/sock" + + it "renders ipv6 sockaddr separated by colons (eight 16-bit groups)" $ do + let addr = SockAddrInet6 + 0 + 0 + (tupleToHostAddress6 (0x2001, 0xdb8, 0, 0, 0, 0, 0, 1)) + 0 + result = sockAddrToIPBytes addr + BS.length result `shouldSatisfy` (> 0) + BC.count ':' result `shouldBe` 7 + mlLoaderModel :: T.Text mlLoaderModel = T.unlines [ "tree"