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.

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
+          let upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig
-          manager <- newManager defaultManagerSettings
+                             * microsPerSecond
+              managerSettings = defaultManagerSettings
+                { managerResponseTimeout = responseTimeoutMicro upstreamMicros
+                }
+          manager <- newManager managerSettings
 
           -- Initialize proxy state (load balancers + health checkers)
           proxyState <- initProxyState config manager

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

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

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

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

PROJECTS/advanced/haskell-reverse-proxy/src/Aenebris/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 upstreamMicros = tcUpstreamReadSeconds defaultTimeoutConfig
-    let status = HTTP.responseStatus backendResponse
+                     * microsPerSecond
-        headers = HTTP.responseHeaders backendResponse
+  mResult <- timeout upstreamMicros $
-        bodyReader = HTTP.responseBody backendResponse
+    withResponse backendReq manager $ \backendResponse -> do
+      let status = HTTP.responseStatus backendResponse
+          headers = HTTP.responseHeaders backendResponse
+          bodyReader = HTTP.responseBody backendResponse
 
-    if shouldStreamResponse headers
+      if shouldStreamResponse headers
-      then do
+        then do
-        hPutStrLn stderr "[STREAM] Streaming response detected"
+          hPutStrLn stderr "[STREAM] Streaming response detected"
-        respond $ responseStream status (filterResponseHeaders headers) $ \write flush -> do
+          respond $ responseStream status (filterResponseHeaders headers) $ \write flush -> do
-          let loop = do
+            let loop = do
-                chunk <- brRead bodyReader
+                  chunk <- brRead bodyReader
-                unless (BS.null chunk) $ do
+                  unless (BS.null chunk) $ do
-                  write (byteString chunk)
+                    write (byteString chunk)
-                  flush
+                    flush
-                  loop
+                    loop
-          loop
+            loop
-      else do
+        else do
-        body <- readFullBody bodyReader
+          body <- readFullBody bodyReader
-        respond $ responseLBS status (filterResponseHeaders headers) body
+          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 =

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

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

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

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

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

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

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

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