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

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.
This commit is contained in:
CarterPerez-dev 2026-04-29 01:59:36 -04:00
parent d3dd5f2dcb
commit 2c7e743f57
8 changed files with 446 additions and 234 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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