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