diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ ## Unreleased +## 0.7.2 + +### Fixed +- Restored the TLS SNI guard for clients without SNI: handshakes now abort before any certificate is sent instead of falling back to the first configured certificate (regression in 0.7.1) + +## 0.7.1.1 + +### Fixed +- Pinned custom quic dependency for FINAL_SIZE_ERROR fix + ## 0.7.1 ### Added diff --git a/hprox.cabal b/hprox.cabal --- a/hprox.cabal +++ b/hprox.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.39.1. +-- This file has been generated from package.yaml by hpack version 0.39.6. -- -- see: https://github.com/sol/hpack name: hprox -version: 0.7.1 +version: 0.7.2 synopsis: a lightweight HTTP proxy server, and more description: Please see the README on GitHub at category: Web diff --git a/src/Network/HProx/DoH.hs b/src/Network/HProx/DoH.hs --- a/src/Network/HProx/DoH.hs +++ b/src/Network/HProx/DoH.hs @@ -113,17 +113,17 @@ case DNS.decode dnsQuery of Right (DNSMessage { question = [q], header = DNSHeader {..} }) -> Just DoHRequest - { dohIdentifier = identifier - , dohQuestion = q - } + { dohIdentifier = identifier + , dohQuestion = q + } _otherwise -> Nothing encodeDoHResponse :: DNS.Identifier -> DNSMessage -> Response encodeDoHResponse ident dnsResp@DNSMessage{header = header} = let encoded = DNS.encode (dnsResp {header = header {identifier = ident} }) in responseKnownLength HT.status200 - [("Content-Type", "application/dns-message")] - (LBS.fromStrict encoded) + [("Content-Type", "application/dns-message")] + (LBS.fromStrict encoded) errorResp :: Response errorResp = responseLBS HT.status400 [("Content-Type", "text/plain")] "invalid dns-over-https request" diff --git a/src/Network/HProx/Impl.hs b/src/Network/HProx/Impl.hs --- a/src/Network/HProx/Impl.hs +++ b/src/Network/HProx/Impl.hs @@ -158,9 +158,9 @@ parseBasicProxyAuthorization authHeader = case BS8.words authHeader of [scheme, payload] | CI.mk scheme == ("basic" :: CI.CI BS.ByteString) - -> either (const Nothing) Just (B64.decode payload) + -> either (const Nothing) Just (B64.decode payload) _otherwise - -> Nothing + -> Nothing redactedCredential :: Maybe BS.ByteString -> BS.ByteString redactedCredential Nothing = "" @@ -202,8 +202,8 @@ | pathInfo req == [".hprox", "config.pac"], Just host' <- lookup forwardedHostHeader (requestHeaders req) <|> requestHeaderHost req = let issecure = case lookup forwardedProtoHeader (requestHeaders req) of - Just proto -> headerValueEquals "https" proto - Nothing -> isSecure req + Just proto -> headerValueEquals "https" proto + Nothing -> isSecure req scheme = if issecure then "HTTPS" else "PROXY" defaultPort = if issecure then ":443" else ":80" host | 58 `BS.elem` host' = host' -- ':' @@ -279,8 +279,7 @@ scheme = lookup xSchemeHeader (requestHeaders req) isHTTP2Proxy = HT.httpMajor (httpVersion req) >= 2 && maybe False (headerValueEquals "http") scheme && isSecure req - (hostPortP, newRawPathP) = BS8.span (/='/') $ - BS.drop (BS.length rawPathPrefix) rawPath + (hostPortP, newRawPathP) = BS8.span (/='/') $ BS.drop (BS.length rawPathPrefix) rawPath parseProxyHostPortWithDefault :: Int -> BS.ByteString -> Maybe (BS.ByteString, Int) parseProxyHostPortWithDefault defaultPort hostPort @@ -346,8 +345,8 @@ if authorized then do forM_ mPaddingType $ \paddingType -> - logger DEBUG $ "naiveproxy padding type detected: " <> toLogStr (show paddingType) <> - " for " <> logRequest req + logger DEBUG $ "naiveproxy padding type detected: " <> toLogStr (show paddingType) <> + " for " <> logRequest req responseStarted <- newIORef False connected <- tryIOException $ runTCPClient settings (respondResponse responseStarted) case connected of diff --git a/src/Network/HProx/Runtime.hs b/src/Network/HProx/Runtime.hs --- a/src/Network/HProx/Runtime.hs +++ b/src/Network/HProx/Runtime.hs @@ -177,20 +177,20 @@ case _doh of Nothing -> runner app Just doh -> createResolver doh (\resolver -> runner (dnsOverHTTPS resolver app)) - where - runner = case selectRunnerPlan conf (tlsCredentialStoreSources credentialStore) of - PlainWarpRunner -> runSettings settings - TlsWarpRunner -> - runTLS (buildTlsSettings lookupSNICredentials') settings + where + runner = case selectRunnerPlan conf (tlsCredentialStoreSources credentialStore) of + PlainWarpRunner -> runSettings settings + TlsWarpRunner -> + runTLS (buildTlsSettings lookupSNICredentials') settings #ifdef QUIC_ENABLED - QuicAndTlsRunner qport -> - runQuicAndTls logger _bind settings (buildTlsSettings lookupSNICredentials') lookupSNICredentials' qport + QuicAndTlsRunner qport -> + runQuicAndTls logger _bind settings (buildTlsSettings lookupSNICredentials') lookupSNICredentials' qport #else - QuicAndTlsRunner _ -> - runTLS (buildTlsSettings lookupSNICredentials') settings + QuicAndTlsRunner _ -> + runTLS (buildTlsSettings lookupSNICredentials') settings #endif - lookupSNICredentials' host = lookupSNICredentialsFromStore host credentialStore + lookupSNICredentials' host = lookupSNICredentialsFromStore host credentialStore buildWarpRuntimePlan :: Config -> WarpRuntimePlan buildWarpRuntimePlan Config{..} = WarpRuntimePlan @@ -370,17 +370,12 @@ lookupSNICredentialsFromStore host store = TLS.Credentials . (: []) <$> lookupTlsCredentialStore host store +-- Clients without a matching SNI hostname, including those sending no SNI, +-- must abort the handshake before any configured certificate is revealed. lookupTlsCredentialStore :: Maybe String -> TlsCredentialStore credential -> IO credential lookupTlsCredentialStore host TlsCredentialStore{..} = do snapshot <- readIORef tlsCredentialStoreSnapshot - case host of - Nothing -> - case snapshot of - [] -> fail "SNI: no TLS credentials configured" - (_, value) : _ -> return $ loadedCredentialValue value - Just _ -> - either fail (return . loadedCredentialValue) (lookupSNIHost host snapshot) - + either fail (return . loadedCredentialValue) (lookupSNIHost host snapshot) lookupSNIHost :: Maybe String -> [(String, a)] -> Either String a lookupSNIHost Nothing _ = Left "SNI: unspecified" diff --git a/test/Network/HProx/AuthSpec.hs b/test/Network/HProx/AuthSpec.hs --- a/test/Network/HProx/AuthSpec.hs +++ b/test/Network/HProx/AuthSpec.hs @@ -21,72 +21,72 @@ spec :: Spec spec = - describe "auth file handling" $ do - it "does not require proxy auth when no auth file is configured" $ do - verifier <- loadProxyAuth (\_ _ -> return ()) Nothing - case verifier of - Nothing -> return () - Just _ -> expectationFailure "expected no proxy auth verifier" + describe "auth file handling" $ do + it "does not require proxy auth when no auth file is configured" $ do + verifier <- loadProxyAuth (\_ _ -> return ()) Nothing + case verifier of + Nothing -> return () + Just _ -> expectationFailure "expected no proxy auth verifier" - it "hashes plaintext entries, ignores invalid lines, and rewrites salted entries" $ - withTempAuthFile "alice:secret\ninvalid-line\nbob:too:many:fields\n" $ \path -> do - verifier <- loadProxyAuth (\_ _ -> return ()) (Just path) - case verifier of - Just verify -> do - verify "alice:secret" `shouldBe` True - verify "alice:wrong" `shouldBe` False - Nothing -> expectationFailure "expected proxy auth verifier" - rewritten <- BS8.lines <$> BS.readFile path - case rewritten of - [line] -> case passwordReader line of - Just ("alice", Salted salt hash) -> do - line `shouldBe` passwordWriter "alice" (PasswordSalted salt hash) - verifyPassword (PasswordSalted salt hash) "secret" `shouldBe` True - verifyPassword (PasswordSalted salt hash) "wrong" `shouldBe` False - parsed -> expectationFailure $ "unexpected rewritten auth line: " <> show parsed - lines' -> expectationFailure $ "unexpected rewritten auth file line count: " <> show (length lines') + it "hashes plaintext entries, ignores invalid lines, and rewrites salted entries" $ + withTempAuthFile "alice:secret\ninvalid-line\nbob:too:many:fields\n" $ \path -> do + verifier <- loadProxyAuth (\_ _ -> return ()) (Just path) + case verifier of + Just verify -> do + verify "alice:secret" `shouldBe` True + verify "alice:wrong" `shouldBe` False + Nothing -> expectationFailure "expected proxy auth verifier" + rewritten <- BS8.lines <$> BS.readFile path + case rewritten of + [line] -> case passwordReader line of + Just ("alice", Salted salt hash) -> do + line `shouldBe` passwordWriter "alice" (PasswordSalted salt hash) + verifyPassword (PasswordSalted salt hash) "secret" `shouldBe` True + verifyPassword (PasswordSalted salt hash) "wrong" `shouldBe` False + parsed -> expectationFailure $ "unexpected rewritten auth line: " <> show parsed + lines' -> expectationFailure $ "unexpected rewritten auth file line count: " <> show (length lines') - it "keeps an already salted file unchanged" $ do - salted <- hashPasswordWithRandomSalt (PlainText "secret") - let line = passwordWriter "alice" salted - original = line <> "\n" - withTempAuthFile original $ \path -> do - _ <- loadProxyAuth (\_ _ -> return ()) (Just path) - rewritten <- BS.readFile path - rewritten `shouldBe` original + it "keeps an already salted file unchanged" $ do + salted <- hashPasswordWithRandomSalt (PlainText "secret") + let line = passwordWriter "alice" salted + original = line <> "\n" + withTempAuthFile original $ \path -> do + _ <- loadProxyAuth (\_ _ -> return ()) (Just path) + rewritten <- BS.readFile path + rewritten `shouldBe` original - it "normalizes CRLF plaintext entries before hashing and verification" $ - withTempAuthFile "alice:secret\r\n" $ \path -> do - Just verifier <- loadProxyAuth (\_ _ -> return ()) (Just path) - verifier "alice:secret" `shouldBe` True - verifier "alice:secret\r" `shouldBe` False - [rewritten] <- BS8.lines <$> BS.readFile path - case passwordReader rewritten of - Just ("alice", Salted salt hash) -> - verifyPassword (PasswordSalted salt hash) "secret" `shouldBe` True - parsed -> expectationFailure $ "unexpected rewritten auth line: " <> show parsed + it "normalizes CRLF plaintext entries before hashing and verification" $ + withTempAuthFile "alice:secret\r\n" $ \path -> do + Just verifier <- loadProxyAuth (\_ _ -> return ()) (Just path) + verifier "alice:secret" `shouldBe` True + verifier "alice:secret\r" `shouldBe` False + [rewritten] <- BS8.lines <$> BS.readFile path + case passwordReader rewritten of + Just ("alice", Salted salt hash) -> + verifyPassword (PasswordSalted salt hash) "secret" `shouldBe` True + parsed -> expectationFailure $ "unexpected rewritten auth line: " <> show parsed - it "redacts malformed auth-file lines in logs" $ - withTempAuthFile "alice:secret:hash:extra\nraw-secret-without-separators\n" $ \path -> do - logs <- newIORef [] - _ <- loadProxyAuth (\_ msg -> modifyIORef' logs (BS8.append (FL.fromLogStr msg) "\n" :)) (Just path) - renderedLogs <- BS.concat . reverse <$> readIORef logs - renderedLogs `shouldSatisfy` BS8.isInfixOf "line 1" - renderedLogs `shouldSatisfy` BS8.isInfixOf "alice" - renderedLogs `shouldSatisfy` BS8.isInfixOf "line 2" - renderedLogs `shouldNotSatisfy` BS8.isInfixOf "secret" - renderedLogs `shouldNotSatisfy` BS8.isInfixOf "hash" - renderedLogs `shouldNotSatisfy` BS8.isInfixOf "extra" - renderedLogs `shouldNotSatisfy` BS8.isInfixOf "raw-secret-without-separators" + it "redacts malformed auth-file lines in logs" $ + withTempAuthFile "alice:secret:hash:extra\nraw-secret-without-separators\n" $ \path -> do + logs <- newIORef [] + _ <- loadProxyAuth (\_ msg -> modifyIORef' logs (BS8.append (FL.fromLogStr msg) "\n" :)) (Just path) + renderedLogs <- BS.concat . reverse <$> readIORef logs + renderedLogs `shouldSatisfy` BS8.isInfixOf "line 1" + renderedLogs `shouldSatisfy` BS8.isInfixOf "alice" + renderedLogs `shouldSatisfy` BS8.isInfixOf "line 2" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "secret" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "hash" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "extra" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "raw-secret-without-separators" withTempAuthFile :: BS.ByteString -> (FilePath -> IO a) -> IO a withTempAuthFile contents action = bracket create cleanup (action . fst) where create = do - (path, handle) <- openTempFile "." "hprox-auth-test" - BS.hPut handle contents - hClose handle - return (path, ()) + (path, handle) <- openTempFile "." "hprox-auth-test" + BS.hPut handle contents + hClose handle + return (path, ()) cleanup (path, ()) = removeFile path diff --git a/test/Network/HProx/ConfigSpec.hs b/test/Network/HProx/ConfigSpec.hs --- a/test/Network/HProx/ConfigSpec.hs +++ b/test/Network/HProx/ConfigSpec.hs @@ -17,122 +17,122 @@ spec :: Spec spec = do - describe "defaultConfig" $ - it "matches the documented default runtime values" $ - assertDefaultConfig defaultConfig + describe "defaultConfig" $ + it "matches the documented default runtime values" $ + assertDefaultConfig defaultConfig - describe "getConfig" $ do - it "uses default configuration when no options are supplied" $ do - conf <- parseConfig [] - assertDefaultConfig conf + describe "getConfig" $ do + it "uses default configuration when no options are supplied" $ do + conf <- parseConfig [] + assertDefaultConfig conf - it "parses long-form options into the current Config fields" $ do - conf <- parseConfig longOptionArgs - _bind conf `shouldBe` Just "127.0.0.1" - _port conf `shouldBe` 8080 - case _ssl conf of - [(host, cert)] -> do - host `shouldBe` "example.com" - certfile cert `shouldBe` "cert.pem" - keyfile cert `shouldBe` "key.pem" - value -> expectationFailure $ "unexpected TLS entries: " <> show (length value) - _auth conf `shouldBe` Just "userpass.txt" - _ws conf `shouldBe` Just "ws.example:443" - _rev conf `shouldBe` [(Just "example.com", "/api/", "upstream:80")] - _doh conf `shouldBe` Just "1.1.1.1:53" - _hide conf `shouldBe` True - _naive conf `shouldBe` True - _name conf `shouldBe` "custom" - _acme conf `shouldBe` Just "thumbprint" - _log conf `shouldBe` "stderr" - _loglevel conf `shouldBe` DEBUG + it "parses long-form options into the current Config fields" $ do + conf <- parseConfig longOptionArgs + _bind conf `shouldBe` Just "127.0.0.1" + _port conf `shouldBe` 8080 + case _ssl conf of + [(host, cert)] -> do + host `shouldBe` "example.com" + certfile cert `shouldBe` "cert.pem" + keyfile cert `shouldBe` "key.pem" + value -> expectationFailure $ "unexpected TLS entries: " <> show (length value) + _auth conf `shouldBe` Just "userpass.txt" + _ws conf `shouldBe` Just "ws.example:443" + _rev conf `shouldBe` [(Just "example.com", "/api/", "upstream:80")] + _doh conf `shouldBe` Just "1.1.1.1:53" + _hide conf `shouldBe` True + _naive conf `shouldBe` True + _name conf `shouldBe` "custom" + _acme conf `shouldBe` Just "thumbprint" + _log conf `shouldBe` "stderr" + _loglevel conf `shouldBe` DEBUG #ifdef OS_UNIX - _user conf `shouldBe` Just "nobody" - _group conf `shouldBe` Just "nogroup" + _user conf `shouldBe` Just "nobody" + _group conf `shouldBe` Just "nogroup" #endif #ifdef QUIC_ENABLED - _quic conf `shouldBe` Just 8443 + _quic conf `shouldBe` Just 8443 #endif - it "parses current short aliases" $ do - conf <- parseConfig shortOptionArgs - _bind conf `shouldBe` Just "0.0.0.0" - _port conf `shouldBe` 8081 - case _ssl conf of - [(host, cert)] -> do - host `shouldBe` "short.example" - certfile cert `shouldBe` "short-cert.pem" - keyfile cert `shouldBe` "short-key.pem" - value -> expectationFailure $ "unexpected TLS entries: " <> show (length value) - _auth conf `shouldBe` Just "short-userpass.txt" + it "parses current short aliases" $ do + conf <- parseConfig shortOptionArgs + _bind conf `shouldBe` Just "0.0.0.0" + _port conf `shouldBe` 8081 + case _ssl conf of + [(host, cert)] -> do + host `shouldBe` "short.example" + certfile cert `shouldBe` "short-cert.pem" + keyfile cert `shouldBe` "short-key.pem" + value -> expectationFailure $ "unexpected TLS entries: " <> show (length value) + _auth conf `shouldBe` Just "short-userpass.txt" #ifdef OS_UNIX - _user conf `shouldBe` Just "daemon" - _group conf `shouldBe` Just "daemon" + _user conf `shouldBe` Just "daemon" + _group conf `shouldBe` Just "daemon" #endif #ifdef QUIC_ENABLED - _quic conf `shouldBe` Just 9443 + _quic conf `shouldBe` Just 9443 #endif - it "parses reverse proxy option forms" $ do - remoteOnly <- parseConfig ["--rev", "backend:80"] - prefixOnly <- parseConfig ["--rev", "/api/backend:80"] - domainAndPrefix <- parseConfig ["--rev", "//example.com/api/backend:80"] - _rev remoteOnly `shouldBe` [(Nothing, "/", "backend:80")] - _rev prefixOnly `shouldBe` [(Nothing, "/api/", "backend:80")] - _rev domainAndPrefix `shouldBe` [(Just "example.com", "/api/", "backend:80")] + it "parses reverse proxy option forms" $ do + remoteOnly <- parseConfig ["--rev", "backend:80"] + prefixOnly <- parseConfig ["--rev", "/api/backend:80"] + domainAndPrefix <- parseConfig ["--rev", "//example.com/api/backend:80"] + _rev remoteOnly `shouldBe` [(Nothing, "/", "backend:80")] + _rev prefixOnly `shouldBe` [(Nothing, "/api/", "backend:80")] + _rev domainAndPrefix `shouldBe` [(Just "example.com", "/api/", "backend:80")] - it "accepts only bounded listener ports" $ do - low <- parseConfig ["--port", "1"] - high <- parseConfig ["--port", "65535"] - _port low `shouldBe` 1 - _port high `shouldBe` 65535 - shouldExitWith ["--port", "0"] (ExitFailure 1) - shouldExitWith ["--port", "65536"] (ExitFailure 1) - shouldExitWith ["--port", "-1"] (ExitFailure 1) + it "accepts only bounded listener ports" $ do + low <- parseConfig ["--port", "1"] + high <- parseConfig ["--port", "65535"] + _port low `shouldBe` 1 + _port high `shouldBe` 65535 + shouldExitWith ["--port", "0"] (ExitFailure 1) + shouldExitWith ["--port", "65536"] (ExitFailure 1) + shouldExitWith ["--port", "-1"] (ExitFailure 1) #ifdef QUIC_ENABLED - it "accepts only bounded QUIC ports" $ do - low <- parseConfig ["--quic", "1"] - high <- parseConfig ["--quic", "65535"] - _quic low `shouldBe` Just 1 - _quic high `shouldBe` Just 65535 - shouldExitWith ["--quic", "0"] (ExitFailure 1) - shouldExitWith ["--quic", "65536"] (ExitFailure 1) - shouldExitWith ["--quic", "-1"] (ExitFailure 1) + it "accepts only bounded QUIC ports" $ do + low <- parseConfig ["--quic", "1"] + high <- parseConfig ["--quic", "65535"] + _quic low `shouldBe` Just 1 + _quic high `shouldBe` Just 65535 + shouldExitWith ["--quic", "0"] (ExitFailure 1) + shouldExitWith ["--quic", "65536"] (ExitFailure 1) + shouldExitWith ["--quic", "-1"] (ExitFailure 1) #endif - it "rejects invalid TLS, reverse proxy, and log-level options" $ do - shouldExitWith ["--tls", "example.com:cert-only"] (ExitFailure 1) - shouldExitWith ["--rev", "//example.com"] (ExitFailure 1) - shouldExitWith ["--rev", "/api/"] (ExitFailure 1) - shouldExitWith ["--rev", "/"] (ExitFailure 1) - shouldExitWith ["--rev", "///api/backend:80"] (ExitFailure 1) - shouldExitWith ["--loglevel", "verbose"] (ExitFailure 1) + it "rejects invalid TLS, reverse proxy, and log-level options" $ do + shouldExitWith ["--tls", "example.com:cert-only"] (ExitFailure 1) + shouldExitWith ["--rev", "//example.com"] (ExitFailure 1) + shouldExitWith ["--rev", "/api/"] (ExitFailure 1) + shouldExitWith ["--rev", "/"] (ExitFailure 1) + shouldExitWith ["--rev", "///api/backend:80"] (ExitFailure 1) + shouldExitWith ["--loglevel", "verbose"] (ExitFailure 1) - it "exercises help and version parser exits" $ do - shouldExitWith ["--help"] ExitSuccess - shouldExitWith ["--version"] ExitSuccess + it "exercises help and version parser exits" $ do + shouldExitWith ["--help"] ExitSuccess + shouldExitWith ["--version"] ExitSuccess assertDefaultConfig :: Config -> Expectation assertDefaultConfig conf = do - _bind conf `shouldBe` Nothing - _port conf `shouldBe` 3000 - length (_ssl conf) `shouldBe` 0 - _auth conf `shouldBe` Nothing - _ws conf `shouldBe` Nothing - _rev conf `shouldBe` [] - _doh conf `shouldBe` Nothing - _hide conf `shouldBe` False - _naive conf `shouldBe` False - _name conf `shouldBe` "hprox" - _acme conf `shouldBe` Nothing - _log conf `shouldBe` "stdout" - _loglevel conf `shouldBe` INFO + _bind conf `shouldBe` Nothing + _port conf `shouldBe` 3000 + length (_ssl conf) `shouldBe` 0 + _auth conf `shouldBe` Nothing + _ws conf `shouldBe` Nothing + _rev conf `shouldBe` [] + _doh conf `shouldBe` Nothing + _hide conf `shouldBe` False + _naive conf `shouldBe` False + _name conf `shouldBe` "hprox" + _acme conf `shouldBe` Nothing + _log conf `shouldBe` "stdout" + _loglevel conf `shouldBe` INFO #ifdef OS_UNIX - _user conf `shouldBe` Nothing - _group conf `shouldBe` Nothing + _user conf `shouldBe` Nothing + _group conf `shouldBe` Nothing #endif #ifdef QUIC_ENABLED - _quic conf `shouldBe` Nothing + _quic conf `shouldBe` Nothing #endif parseConfig :: [String] -> IO Config @@ -140,46 +140,46 @@ shouldExitWith :: [String] -> ExitCode -> Expectation shouldExitWith args expected = do - result <- try (parseConfig args) - case result of - Left exitCode -> exitCode `shouldBe` expected - Right _ -> expectationFailure "expected parser to exit" + result <- try (parseConfig args) + case result of + Left exitCode -> exitCode `shouldBe` expected + Right _ -> expectationFailure "expected parser to exit" longOptionArgs :: [String] longOptionArgs = - [ "--bind", "127.0.0.1" - , "--port", "8080" - , "--tls", "example.com:cert.pem:key.pem" - , "--auth", "userpass.txt" - , "--ws", "ws.example:443" - , "--rev", "//example.com/api/upstream:80" - , "--doh", "1.1.1.1:53" - , "--hide" - , "--naive" - , "--name", "custom" - , "--acme", "thumbprint" - , "--log", "stderr" - , "--loglevel", "debug" + [ "--bind", "127.0.0.1" + , "--port", "8080" + , "--tls", "example.com:cert.pem:key.pem" + , "--auth", "userpass.txt" + , "--ws", "ws.example:443" + , "--rev", "//example.com/api/upstream:80" + , "--doh", "1.1.1.1:53" + , "--hide" + , "--naive" + , "--name", "custom" + , "--acme", "thumbprint" + , "--log", "stderr" + , "--loglevel", "debug" #ifdef OS_UNIX - , "--user", "nobody" - , "--group", "nogroup" + , "--user", "nobody" + , "--group", "nogroup" #endif #ifdef QUIC_ENABLED - , "--quic", "8443" + , "--quic", "8443" #endif - ] + ] shortOptionArgs :: [String] shortOptionArgs = - [ "-b", "0.0.0.0" - , "-p", "8081" - , "-s", "short.example:short-cert.pem:short-key.pem" - , "-a", "short-userpass.txt" + [ "-b", "0.0.0.0" + , "-p", "8081" + , "-s", "short.example:short-cert.pem:short-key.pem" + , "-a", "short-userpass.txt" #ifdef OS_UNIX - , "-u", "daemon" - , "-g", "daemon" + , "-u", "daemon" + , "-g", "daemon" #endif #ifdef QUIC_ENABLED - , "-q", "9443" + , "-q", "9443" #endif - ] + ] diff --git a/test/Network/HProx/DoHSpec.hs b/test/Network/HProx/DoHSpec.hs --- a/test/Network/HProx/DoHSpec.hs +++ b/test/Network/HProx/DoHSpec.hs @@ -21,68 +21,68 @@ spec :: Spec spec = - describe "dnsOverHTTPS" $ do - it "handles secure GET /dns-query requests with unpadded URL-safe base64" $ do - response <- runDoHRequest getDnsRequest - simpleStatus response `shouldBe` HT.status200 - lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/dns-message" - decodedResponse response `shouldSatisfy` hasRequestIdentifier + describe "dnsOverHTTPS" $ do + it "handles secure GET /dns-query requests with unpadded URL-safe base64" $ do + response <- runDoHRequest getDnsRequest + simpleStatus response `shouldBe` HT.status200 + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/dns-message" + decodedResponse response `shouldSatisfy` hasRequestIdentifier - it "handles secure POST /dns-query requests with application/dns-message bodies" $ do - response <- runDoHRequest postDnsRequest - simpleStatus response `shouldBe` HT.status200 - lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/dns-message" - decodedResponse response `shouldSatisfy` hasRequestIdentifier + it "handles secure POST /dns-query requests with application/dns-message bodies" $ do + response <- runDoHRequest postDnsRequest + simpleStatus response `shouldBe` HT.status200 + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/dns-message" + decodedResponse response `shouldSatisfy` hasRequestIdentifier - it "returns the current text 400 response for malformed requests" $ do - response <- runDoHRequest getDnsRequest { queryString = [("dns", Just "not-base64!")] } - simpleStatus response `shouldBe` HT.status400 - lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "text/plain" - simpleBody response `shouldBe` "invalid dns-over-https request" + it "returns the current text 400 response for malformed requests" $ do + response <- runDoHRequest getDnsRequest { queryString = [("dns", Just "not-base64!")] } + simpleStatus response `shouldBe` HT.status400 + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "text/plain" + simpleBody response `shouldBe` "invalid dns-over-https request" - it "rejects POST bodies beyond the current 4096-byte boundary" $ do - response <- runDoHRequestWithBody postDnsRequest { requestBodyLength = KnownLength 4097 } (LBS.replicate 4097 0) - simpleStatus response `shouldBe` HT.status400 - simpleBody response `shouldBe` "invalid dns-over-https request" + it "rejects POST bodies beyond the current 4096-byte boundary" $ do + response <- runDoHRequestWithBody postDnsRequest { requestBodyLength = KnownLength 4097 } (LBS.replicate 4097 0) + simpleStatus response `shouldBe` HT.status400 + simpleBody response `shouldBe` "invalid dns-over-https request" - it "accepts chunked POST bodies within the size boundary" $ do - response <- runDoHRequestWithBody postDnsRequest { requestBodyLength = ChunkedBody } (LBS.fromStrict encodedQuery) - simpleStatus response `shouldBe` HT.status200 - lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/dns-message" - decodedResponse response `shouldSatisfy` hasRequestIdentifier + it "accepts chunked POST bodies within the size boundary" $ do + response <- runDoHRequestWithBody postDnsRequest { requestBodyLength = ChunkedBody } (LBS.fromStrict encodedQuery) + simpleStatus response `shouldBe` HT.status200 + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/dns-message" + decodedResponse response `shouldSatisfy` hasRequestIdentifier - it "rejects chunked POST bodies beyond the size boundary" $ do - response <- runDoHRequestWithBody postDnsRequest { requestBodyLength = ChunkedBody } (LBS.replicate 4097 0) - simpleStatus response `shouldBe` HT.status400 - simpleBody response `shouldBe` "invalid dns-over-https request" + it "rejects chunked POST bodies beyond the size boundary" $ do + response <- runDoHRequestWithBody postDnsRequest { requestBodyLength = ChunkedBody } (LBS.replicate 4097 0) + simpleStatus response `shouldBe` HT.status400 + simpleBody response `shouldBe` "invalid dns-over-https request" - it "returns 502 when the DNS resolver fails" $ do - response <- runDoHRequestWithApplication resolverFailureApplication getDnsRequest "" - simpleStatus response `shouldBe` HT.status502 - simpleBody response `shouldBe` "dns resolver failure" + it "returns 502 when the DNS resolver fails" $ do + response <- runDoHRequestWithApplication resolverFailureApplication getDnsRequest "" + simpleStatus response `shouldBe` HT.status502 + simpleBody response `shouldBe` "dns resolver failure" - it "parses valid POST bodies split across multiple chunks" $ do - chunks <- newIORef [BS.take 5 encodedQuery, BS.drop 5 encodedQuery] - parsed <- parseDoHRequestWithBodyReader (popChunk chunks) postDnsRequest - parsed `shouldBe` Just DoHRequest - { dohIdentifier = requestIdentifier - , dohQuestion = decodedQuestion - } + it "parses valid POST bodies split across multiple chunks" $ do + chunks <- newIORef [BS.take 5 encodedQuery, BS.drop 5 encodedQuery] + parsed <- parseDoHRequestWithBodyReader (popChunk chunks) postDnsRequest + parsed `shouldBe` Just DoHRequest + { dohIdentifier = requestIdentifier + , dohQuestion = decodedQuestion + } - it "falls through outside secure /dns-query requests" $ do - insecureResponse <- runDoHRequest getDnsRequest { isSecure = False } - otherPathResponse <- runDoHRequest getDnsRequest { pathInfo = ["other"], rawPathInfo = "/other" } - simpleStatus insecureResponse `shouldBe` fallbackStatus - simpleBody insecureResponse `shouldBe` fallbackBody - simpleStatus otherPathResponse `shouldBe` fallbackStatus - simpleBody otherPathResponse `shouldBe` fallbackBody + it "falls through outside secure /dns-query requests" $ do + insecureResponse <- runDoHRequest getDnsRequest { isSecure = False } + otherPathResponse <- runDoHRequest getDnsRequest { pathInfo = ["other"], rawPathInfo = "/other" } + simpleStatus insecureResponse `shouldBe` fallbackStatus + simpleBody insecureResponse `shouldBe` fallbackBody + simpleStatus otherPathResponse `shouldBe` fallbackStatus + simpleBody otherPathResponse `shouldBe` fallbackBody runDoHRequest :: Request -> IO SResponse runDoHRequest req = runDoHRequestWithBody req requestBody where requestBody - | requestMethod req == "POST" = LBS.fromStrict encodedQuery - | otherwise = "" + | requestMethod req == "POST" = LBS.fromStrict encodedQuery + | otherwise = "" runDoHRequestWithBody :: Request -> LBS.ByteString -> IO SResponse runDoHRequestWithBody req body = runSession (srequest $ SRequest req body) testApplication @@ -92,12 +92,12 @@ popChunk :: IORef [BS.ByteString] -> IO BS.ByteString popChunk chunksRef = do - chunks <- readIORef chunksRef - case chunks of - [] -> return "" - chunk : rest -> do - writeIORef chunksRef rest - return chunk + chunks <- readIORef chunksRef + case chunks of + [] -> return "" + chunk : rest -> do + writeIORef chunksRef rest + return chunk testApplication :: Application testApplication = dnsOverHTTPSWithLookup lookupResponse fallback @@ -122,39 +122,39 @@ getDnsRequest :: Request getDnsRequest = secureDnsRequest - { requestMethod = "GET" - , queryString = [("dns", Just (Base64.encodeUnpadded encodedQuery))] - } + { requestMethod = "GET" + , queryString = [("dns", Just (Base64.encodeUnpadded encodedQuery))] + } postDnsRequest :: Request postDnsRequest = secureDnsRequest - { requestMethod = "POST" - , requestBodyLength = KnownLength (fromIntegral $ LBS.length requestBody) - } + { requestMethod = "POST" + , requestBodyLength = KnownLength (fromIntegral $ LBS.length requestBody) + } where requestBody = LBS.fromStrict encodedQuery secureDnsRequest :: Request secureDnsRequest = defaultRequest - { isSecure = True - , pathInfo = ["dns-query"] - , rawPathInfo = "/dns-query" - } + { isSecure = True + , pathInfo = ["dns-query"] + , rawPathInfo = "/dns-query" + } encodedQuery :: BS.ByteString encodedQuery = DNS.encode queryMessage queryMessage :: DNS.DNSMessage queryMessage = DNS.defaultQuery - { DNS.header = (DNS.header DNS.defaultQuery) { DNS.identifier = requestIdentifier } - , DNS.question = [question] - } + { DNS.header = (DNS.header DNS.defaultQuery) { DNS.identifier = requestIdentifier } + , DNS.question = [question] + } question :: DNS.Question question = DNS.Question - { DNS.qname = "example.com" - , DNS.qtype = DNS.A - } + { DNS.qname = "example.com" + , DNS.qtype = DNS.A + } decodedQuestion :: DNS.Question decodedQuestion = question { DNS.qname = "example.com." } @@ -170,5 +170,5 @@ hasRequestIdentifier :: Either DNS.DNSError DNS.DNSMessage -> Bool hasRequestIdentifier (Right DNS.DNSMessage{DNS.header = DNS.DNSHeader{DNS.identifier = ident}}) = - ident == requestIdentifier + ident == requestIdentifier hasRequestIdentifier _ = False diff --git a/test/Network/HProx/HeadersSpec.hs b/test/Network/HProx/HeadersSpec.hs --- a/test/Network/HProx/HeadersSpec.hs +++ b/test/Network/HProx/HeadersSpec.hs @@ -12,23 +12,23 @@ spec :: Spec spec = - describe "header policy helpers" $ do - it "detects proxy, forwarded, and CDN header families" $ do - isProxyHeader "Proxy-Connection" `shouldBe` True - isForwardedHeader "X-Forwarded-For" `shouldBe` True - isCDNHeader "cf-ray" `shouldBe` True - isCDNHeader cdnLoopHeader `shouldBe` True + describe "header policy helpers" $ do + it "detects proxy, forwarded, and CDN header families" $ do + isProxyHeader "Proxy-Connection" `shouldBe` True + isForwardedHeader "X-Forwarded-For" `shouldBe` True + isCDNHeader "cf-ray" `shouldBe` True + isCDNHeader cdnLoopHeader `shouldBe` True - isForwardedHeader "Forwarded" `shouldBe` True - isForwardedHeader "forwarded-for" `shouldBe` False - it "preserves the current strip-header policy" $ do - map isProxyStripHeader ["Proxy-Connection", "X-Forwarded-Proto", "cf-ray", xRealIPHeader, xSchemeHeader] - `shouldBe` replicate 5 True - isProxyStripHeader "Authorization" `shouldBe` False - isProxyStripHeader "Forwarded" `shouldBe` True - isProxyStripHeader "X-Not-Forwarded" `shouldBe` False + isForwardedHeader "Forwarded" `shouldBe` True + isForwardedHeader "forwarded-for" `shouldBe` False + it "preserves the current strip-header policy" $ do + map isProxyStripHeader ["Proxy-Connection", "X-Forwarded-Proto", "cf-ray", xRealIPHeader, xSchemeHeader] + `shouldBe` replicate 5 True + isProxyStripHeader "Authorization" `shouldBe` False + isProxyStripHeader "Forwarded" `shouldBe` True + isProxyStripHeader "X-Not-Forwarded" `shouldBe` False - it "compares protocol header values case-insensitively" $ do - headerValueEquals "https" "HTTPS" `shouldBe` True - headerValueEquals "http" "HtTp" `shouldBe` True - headerValueEquals "http" "https" `shouldBe` False + it "compares protocol header values case-insensitively" $ do + headerValueEquals "https" "HTTPS" `shouldBe` True + headerValueEquals "http" "HtTp" `shouldBe` True + headerValueEquals "http" "https" `shouldBe` False diff --git a/test/Network/HProx/MiddlewareSpec.hs b/test/Network/HProx/MiddlewareSpec.hs --- a/test/Network/HProx/MiddlewareSpec.hs +++ b/test/Network/HProx/MiddlewareSpec.hs @@ -18,115 +18,115 @@ spec :: Spec spec = do - describe "healthCheckProvider" $ do - it "returns 200 okay for the health endpoint" $ do - response <- runApp healthCheckProvider (requestPath "/.hprox/health") - simpleStatus response `shouldBe` HT.status200 - simpleBody response `shouldBe` "okay" + describe "healthCheckProvider" $ do + it "returns 200 okay for the health endpoint" $ do + response <- runApp healthCheckProvider (requestPath "/.hprox/health") + simpleStatus response `shouldBe` HT.status200 + simpleBody response `shouldBe` "okay" - it "falls through outside the health endpoint" $ do - response <- runApp healthCheckProvider (requestPath "/not-health") - simpleStatus response `shouldBe` fallbackStatus - simpleBody response `shouldBe` fallbackBody + it "falls through outside the health endpoint" $ do + response <- runApp healthCheckProvider (requestPath "/not-health") + simpleStatus response `shouldBe` fallbackStatus + simpleBody response `shouldBe` fallbackBody - describe "acmeProvider" $ do - it "serves an insecure challenge when a thumbprint is configured" $ do - response <- runApp (acmeProvider testSettings) (requestPath "/.well-known/acme-challenge/token") - simpleStatus response `shouldBe` HT.status200 - simpleBody response `shouldBe` "token.thumbprint" - lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "text/plain" + describe "acmeProvider" $ do + it "serves an insecure challenge when a thumbprint is configured" $ do + response <- runApp (acmeProvider testSettings) (requestPath "/.well-known/acme-challenge/token") + simpleStatus response `shouldBe` HT.status200 + simpleBody response `shouldBe` "token.thumbprint" + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "text/plain" - it "falls through for secure ACME requests" $ do - response <- runApp (acmeProvider testSettings) $ (requestPath "/.well-known/acme-challenge/token") - { isSecure = True - } - simpleStatus response `shouldBe` fallbackStatus + it "falls through for secure ACME requests" $ do + response <- runApp (acmeProvider testSettings) $ (requestPath "/.well-known/acme-challenge/token") + { isSecure = True + } + simpleStatus response `shouldBe` fallbackStatus - it "falls through without a configured thumbprint" $ do - response <- runApp (acmeProvider testSettings { acmeThumbprint = Nothing }) (requestPath "/.well-known/acme-challenge/token") - simpleStatus response `shouldBe` fallbackStatus + it "falls through without a configured thumbprint" $ do + response <- runApp (acmeProvider testSettings { acmeThumbprint = Nothing }) (requestPath "/.well-known/acme-challenge/token") + simpleStatus response `shouldBe` fallbackStatus - describe "pacProvider" $ do - it "uses forwarded host and lowercase https proto for the PAC response" $ do - response <- runApp pacProvider $ (requestPath "/.hprox/config.pac") - { requestHeaders = [("x-forwarded-host", "proxy.example"), ("x-forwarded-proto", "https")] - } - simpleStatus response `shouldBe` HT.status200 - simpleBody response `shouldBe` LBS8.unlines - [ "function FindProxyForURL(url, host) {" - , " return \"HTTPS proxy.example:443\";" - , "}" - ] - lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/x-ns-proxy-autoconfig" + describe "pacProvider" $ do + it "uses forwarded host and lowercase https proto for the PAC response" $ do + response <- runApp pacProvider $ (requestPath "/.hprox/config.pac") + { requestHeaders = [("x-forwarded-host", "proxy.example"), ("x-forwarded-proto", "https")] + } + simpleStatus response `shouldBe` HT.status200 + simpleBody response `shouldBe` LBS8.unlines + [ "function FindProxyForURL(url, host) {" + , " return \"HTTPS proxy.example:443\";" + , "}" + ] + lookup "Content-Type" (simpleHeaders response) `shouldBe` Just "application/x-ns-proxy-autoconfig" - it "uses Host and preserves an explicit host port for insecure PAC responses" $ do - response <- runApp pacProvider $ (requestPath "/.hprox/config.pac") - { requestHeaderHost = Just "proxy.example:8080" - } - simpleStatus response `shouldBe` HT.status200 - simpleBody response `shouldBe` LBS8.unlines - [ "function FindProxyForURL(url, host) {" - , " return \"PROXY proxy.example:8080\";" - , "}" - ] + it "uses Host and preserves an explicit host port for insecure PAC responses" $ do + response <- runApp pacProvider $ (requestPath "/.hprox/config.pac") + { requestHeaderHost = Just "proxy.example:8080" + } + simpleStatus response `shouldBe` HT.status200 + simpleBody response `shouldBe` LBS8.unlines + [ "function FindProxyForURL(url, host) {" + , " return \"PROXY proxy.example:8080\";" + , "}" + ] - it "treats forwarded proto values case-insensitively" $ do - response <- runApp pacProvider $ (requestPath "/.hprox/config.pac") - { requestHeaders = [("x-forwarded-host", "proxy.example"), ("x-forwarded-proto", "HTTPS")] - } - simpleStatus response `shouldBe` HT.status200 - simpleBody response `shouldBe` LBS8.unlines - [ "function FindProxyForURL(url, host) {" - , " return \"HTTPS proxy.example:443\";" - , "}" - ] + it "treats forwarded proto values case-insensitively" $ do + response <- runApp pacProvider $ (requestPath "/.hprox/config.pac") + { requestHeaders = [("x-forwarded-host", "proxy.example"), ("x-forwarded-proto", "HTTPS")] + } + simpleStatus response `shouldBe` HT.status200 + simpleBody response `shouldBe` LBS8.unlines + [ "function FindProxyForURL(url, host) {" + , " return \"HTTPS proxy.example:443\";" + , "}" + ] - it "falls through without a host" $ do - response <- runApp pacProvider (requestPath "/.hprox/config.pac") - simpleStatus response `shouldBe` fallbackStatus + it "falls through without a host" $ do + response <- runApp pacProvider (requestPath "/.hprox/config.pac") + simpleStatus response `shouldBe` fallbackStatus - describe "forceSSL" $ do - it "redirects insecure origin-form requests with path and query to HTTPS" $ do - response <- runApp (forceSSL testSettings) $ (requestPath "/docs") - { requestHeaderHost = Just "example.com" - , rawQueryString = "?q=1" - } - simpleStatus response `shouldBe` HT.status301 - lookup "Location" (simpleHeaders response) `shouldBe` Just "https://example.com/docs?q=1" + describe "forceSSL" $ do + it "redirects insecure origin-form requests with path and query to HTTPS" $ do + response <- runApp (forceSSL testSettings) $ (requestPath "/docs") + { requestHeaderHost = Just "example.com" + , rawQueryString = "?q=1" + } + simpleStatus response `shouldBe` HT.status301 + lookup "Location" (simpleHeaders response) `shouldBe` Just "https://example.com/docs?q=1" - it "redirects root origin-form requests to the HTTPS root" $ do - response <- runApp (forceSSL testSettings) $ defaultRequest - { requestHeaderHost = Just "example.com" - , rawPathInfo = "/" - } - simpleStatus response `shouldBe` HT.status301 - lookup "Location" (simpleHeaders response) `shouldBe` Just "https://example.com/" + it "redirects root origin-form requests to the HTTPS root" $ do + response <- runApp (forceSSL testSettings) $ defaultRequest + { requestHeaderHost = Just "example.com" + , rawPathInfo = "/" + } + simpleStatus response `shouldBe` HT.status301 + lookup "Location" (simpleHeaders response) `shouldBe` Just "https://example.com/" - it "redirects insecure absolute-form proxy requests to the parsed HTTPS target" $ do - response <- runApp (forceSSL testSettings) $ defaultRequest - { requestHeaderHost = Just "proxy.local" - , rawPathInfo = "http://target.example:8080/docs" - , rawQueryString = "?q=1" - } - simpleStatus response `shouldBe` HT.status301 - lookup "Location" (simpleHeaders response) `shouldBe` Just "https://target.example:8080/docs?q=1" + it "redirects insecure absolute-form proxy requests to the parsed HTTPS target" $ do + response <- runApp (forceSSL testSettings) $ defaultRequest + { requestHeaderHost = Just "proxy.local" + , rawPathInfo = "http://target.example:8080/docs" + , rawQueryString = "?q=1" + } + simpleStatus response `shouldBe` HT.status301 + lookup "Location" (simpleHeaders response) `shouldBe` Just "https://target.example:8080/docs?q=1" - it "omits default ports from absolute-form HTTPS redirect authorities" $ do - response <- runApp (forceSSL testSettings) $ defaultRequest - { requestHeaderHost = Just "proxy.local" - , rawPathInfo = "http://target.example/docs" - } - simpleStatus response `shouldBe` HT.status301 - lookup "Location" (simpleHeaders response) `shouldBe` Just "https://target.example/docs" + it "omits default ports from absolute-form HTTPS redirect authorities" $ do + response <- runApp (forceSSL testSettings) $ defaultRequest + { requestHeaderHost = Just "proxy.local" + , rawPathInfo = "http://target.example/docs" + } + simpleStatus response `shouldBe` HT.status301 + lookup "Location" (simpleHeaders response) `shouldBe` Just "https://target.example/docs" - it "returns upgrade-required for insecure requests without Host" $ do - response <- runApp (forceSSL testSettings) defaultRequest - simpleStatus response `shouldBe` HT.mkStatus 426 "Upgrade Required" - lookup "Upgrade" (simpleHeaders response) `shouldBe` Just "TLS/1.0, HTTP/1.1" + it "returns upgrade-required for insecure requests without Host" $ do + response <- runApp (forceSSL testSettings) defaultRequest + simpleStatus response `shouldBe` HT.mkStatus 426 "Upgrade Required" + lookup "Upgrade" (simpleHeaders response) `shouldBe` Just "TLS/1.0, HTTP/1.1" - it "falls through for secure requests" $ do - response <- runApp (forceSSL testSettings) defaultRequest { isSecure = True } - simpleStatus response `shouldBe` fallbackStatus + it "falls through for secure requests" $ do + response <- runApp (forceSSL testSettings) defaultRequest { isSecure = True } + simpleStatus response `shouldBe` fallbackStatus runApp :: Middleware -> Request -> IO SResponse runApp middleware req = runSession (srequest $ SRequest req "") (middleware fallback) @@ -145,12 +145,12 @@ testSettings :: ProxySettings testSettings = ProxySettings - { proxyAuth = Nothing - , passPrompt = Just "hprox" - , wsRemote = Nothing - , revRemoteMap = [] - , hideProxyAuth = False - , naivePadding = False - , acmeThumbprint = Just "thumbprint" - , logger = \_ _ -> return () - } + { proxyAuth = Nothing + , passPrompt = Just "hprox" + , wsRemote = Nothing + , revRemoteMap = [] + , hideProxyAuth = False + , naivePadding = False + , acmeThumbprint = Just "thumbprint" + , logger = \_ _ -> return () + } diff --git a/test/Network/HProx/NaiveSpec.hs b/test/Network/HProx/NaiveSpec.hs --- a/test/Network/HProx/NaiveSpec.hs +++ b/test/Network/HProx/NaiveSpec.hs @@ -17,30 +17,30 @@ spec :: Spec spec = do - describe "parseRequestForPadding" $ do - it "selects the first supported padding type from the request header" $ do - parseRequestForPadding defaultRequest - { requestHeaders = [("Padding-Type-Request", "unknown,1,0")] - } - `shouldBe` Just Variant1 + describe "parseRequestForPadding" $ do + it "selects the first supported padding type from the request header" $ do + parseRequestForPadding defaultRequest + { requestHeaders = [("Padding-Type-Request", "unknown,1,0")] + } + `shouldBe` Just Variant1 - it "falls back to the legacy Padding header" $ do - parseRequestForPadding defaultRequest - { requestHeaders = [("Padding", "opaque")] - } - `shouldBe` Just Variant1 + it "falls back to the legacy Padding header" $ do + parseRequestForPadding defaultRequest + { requestHeaders = [("Padding", "opaque")] + } + `shouldBe` Just Variant1 - it "rejects requests without supported padding headers" $ - parseRequestForPadding defaultRequest - { requestHeaders = [("Padding-Type-Request", "unknown")] - } - `shouldBe` Nothing + it "rejects requests without supported padding headers" $ + parseRequestForPadding defaultRequest + { requestHeaders = [("Padding-Type-Request", "unknown")] + } + `shouldBe` Nothing - describe "padding conduits" $ do - it "round-trips NoPadding without changing chunks" $ do - chunks <- runConduit $ CL.sourceList ["hello", "world"] .| addPaddingConduit NoPadding .| removePaddingConduit NoPadding .| CL.consume - chunks `shouldBe` ["hello", "world"] + describe "padding conduits" $ do + it "round-trips NoPadding without changing chunks" $ do + chunks <- runConduit $ CL.sourceList ["hello", "world"] .| addPaddingConduit NoPadding .| removePaddingConduit NoPadding .| CL.consume + chunks `shouldBe` ["hello", "world"] - it "round-trips Variant1 payloads without depending on random padding bytes" $ do - chunks <- runConduit $ CL.sourceList [BS.replicate 512 65] .| addPaddingConduit Variant1 .| removePaddingConduit Variant1 .| CL.consume - BS.concat chunks `shouldBe` BS.replicate 512 65 + it "round-trips Variant1 payloads without depending on random padding bytes" $ do + chunks <- runConduit $ CL.sourceList [BS.replicate 512 65] .| addPaddingConduit Variant1 .| removePaddingConduit Variant1 .| CL.consume + BS.concat chunks `shouldBe` BS.replicate 512 65 diff --git a/test/Network/HProx/ProxySpec.hs b/test/Network/HProx/ProxySpec.hs --- a/test/Network/HProx/ProxySpec.hs +++ b/test/Network/HProx/ProxySpec.hs @@ -39,225 +39,226 @@ spec :: Spec spec = do - describe "HTTP proxy auth decisions" $ do - it "challenges unauthorized HTTP proxy requests" $ do - response <- runProxyApp (httpProxy authRequiredSettings) rawProxyRequest - simpleStatus response `shouldBe` HT.status407 - lookup "Proxy-Authenticate" (simpleHeaders response) `shouldBe` Just "Basic realm=\"hprox\"" + describe "HTTP proxy auth decisions" $ do + it "challenges unauthorized HTTP proxy requests" $ do + response <- runProxyApp (httpProxy authRequiredSettings) rawProxyRequest + simpleStatus response `shouldBe` HT.status407 + lookup "Proxy-Authenticate" (simpleHeaders response) `shouldBe` Just "Basic realm=\"hprox\"" - it "accepts valid Basic credentials" $ - withRawHttpServer (const "ok") $ \port -> do - response <- runProxyApp (httpProxy authorizedSettings) (proxyRequestForPort port basicAliceSecret) - simpleStatus response `shouldBe` HT.status200 + it "accepts valid Basic credentials" $ + withRawHttpServer (const "ok") $ \port -> do + response <- runProxyApp (httpProxy authorizedSettings) (proxyRequestForPort port basicAliceSecret) + simpleStatus response `shouldBe` HT.status200 - it "rejects valid Basic credentials with the wrong password" $ do - response <- runProxyApp (httpProxy authorizedSettings) (rawProxyRequestWithAuth $ basicCredential "alice:wrong") - simpleStatus response `shouldBe` HT.status407 + it "rejects valid Basic credentials with the wrong password" $ do + response <- runProxyApp (httpProxy authorizedSettings) (rawProxyRequestWithAuth $ basicCredential "alice:wrong") + simpleStatus response `shouldBe` HT.status407 - it "rejects malformed base64 credentials even if lenient decoding would authenticate" $ do - response <- runProxyApp (httpProxy authorizedSettings) (rawProxyRequestWithAuth "Basic !!!YWxpY2U6c2VjcmV0!!!") - simpleStatus response `shouldBe` HT.status407 + it "rejects malformed base64 credentials even if lenient decoding would authenticate" $ do + response <- runProxyApp (httpProxy authorizedSettings) (rawProxyRequestWithAuth "Basic !!!YWxpY2U6c2VjcmV0!!!") + simpleStatus response `shouldBe` HT.status407 - it "rejects non-Basic credentials even when the payload is otherwise valid" $ do - response <- runProxyApp (httpProxy authorizedSettings) (rawProxyRequestWithAuth $ "Bearer " <> B64.encode "alice:secret") - simpleStatus response `shouldBe` HT.status407 + it "rejects non-Basic credentials even when the payload is otherwise valid" $ do + response <- runProxyApp (httpProxy authorizedSettings) (rawProxyRequestWithAuth $ "Bearer " <> B64.encode "alice:secret") + simpleStatus response `shouldBe` HT.status407 - it "redacts proxy auth passwords in trace logs" $ - withRawHttpServer (const "ok") $ \port -> do - logs <- newIORef [] - let loggingSettings = authorizedSettings - { logger = \_ msg -> modifyIORef' logs (LBS.fromStrict (FL.fromLogStr msg) :) - } - response <- runProxyApp (httpProxy loggingSettings) (proxyRequestForPort port basicAliceSecret) - simpleStatus response `shouldBe` HT.status200 - renderedLogs <- LBS.toStrict . LBS.concat . reverse <$> readIORef logs - renderedLogs `shouldSatisfy` BS8.isInfixOf "authorized request" - renderedLogs `shouldSatisfy` BS8.isInfixOf "alice:" - renderedLogs `shouldNotSatisfy` BS8.isInfixOf "secret" - renderedLogs `shouldNotSatisfy` BS8.isInfixOf "alice:secret" + it "redacts proxy auth passwords in trace logs" $ + withRawHttpServer (const "ok") $ \port -> do + logs <- newIORef [] + let loggingSettings = authorizedSettings + { logger = \_ msg -> modifyIORef' logs (LBS.fromStrict (FL.fromLogStr msg) :) + } + response <- runProxyApp (httpProxy loggingSettings) (proxyRequestForPort port basicAliceSecret) + simpleStatus response `shouldBe` HT.status200 + renderedLogs <- LBS.toStrict . LBS.concat . reverse <$> readIORef logs + renderedLogs `shouldSatisfy` BS8.isInfixOf "authorized request" + renderedLogs `shouldSatisfy` BS8.isInfixOf "alice:" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "secret" + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "alice:secret" - it "falls back instead of challenging when hidden auth is enabled" $ do - response <- runProxyApp (httpProxy hiddenAuthSettings) rawProxyRequest - simpleStatus response `shouldBe` fallbackStatus - simpleBody response `shouldBe` fallbackBody + it "falls back instead of challenging when hidden auth is enabled" $ do + response <- runProxyApp (httpProxy hiddenAuthSettings) rawProxyRequest + simpleStatus response `shouldBe` fallbackStatus + simpleBody response `shouldBe` fallbackBody - describe "CONNECT proxy auth decisions" $ do - it "challenges unauthorized CONNECT requests" $ do - response <- runConnectApp authRequiredSettings connectRequest - simpleStatus response `shouldBe` HT.status407 - lookup "Proxy-Authenticate" (simpleHeaders response) `shouldBe` Just "Basic realm=\"hprox\"" + describe "CONNECT proxy auth decisions" $ do + it "challenges unauthorized CONNECT requests" $ do + response <- runConnectApp authRequiredSettings connectRequest + simpleStatus response `shouldBe` HT.status407 + lookup "Proxy-Authenticate" (simpleHeaders response) `shouldBe` Just "Basic realm=\"hprox\"" - it "falls back instead of challenging CONNECT requests when hidden auth is enabled" $ do - response <- runConnectApp hiddenAuthSettings connectRequest - simpleStatus response `shouldBe` fallbackStatus - simpleBody response `shouldBe` fallbackBody + it "falls back instead of challenging CONNECT requests when hidden auth is enabled" $ do + response <- runConnectApp hiddenAuthSettings connectRequest + simpleStatus response `shouldBe` fallbackStatus + simpleBody response `shouldBe` fallbackBody - it "establishes an HTTP/1 CONNECT tunnel after upstream connection succeeds" $ do - response <- rawConnectRoundTrip - response `shouldBe` "ping" + it "establishes an HTTP/1 CONNECT tunnel after upstream connection succeeds" $ do + response <- rawConnectRoundTrip + response `shouldBe` "ping" - it "returns 502 when upstream CONNECT fails before tunnel establishment" $ do - port <- getFreePort - response <- runConnectApp authorizedSettings (connectRequestFor "127.0.0.1" port HT.http11) - simpleStatus response `shouldBe` HT.status502 + it "returns 502 when upstream CONNECT fails before tunnel establishment" $ do + port <- getFreePort + response <- runConnectApp authorizedSettings (connectRequestFor "127.0.0.1" port HT.http11) + simpleStatus response `shouldBe` HT.status502 - it "returns 502 for HTTP/2 CONNECT when upstream connection fails" $ do - port <- getFreePort - response <- runConnectApp authorizedSettings (connectRequestFor "127.0.0.1" port HT.http20) - simpleStatus response `shouldBe` HT.status502 + it "returns 502 for HTTP/2 CONNECT when upstream connection fails" $ do + port <- getFreePort + response <- runConnectApp authorizedSettings (connectRequestFor "127.0.0.1" port HT.http20) + simpleStatus response `shouldBe` HT.status502 - it "does not log upstream failure after an HTTP/2 tunnel response starts" $ - withTcpEchoServer $ \targetPort -> do - logs <- newIORef [] - let loggingSettings = authorizedSettings - { logger = \_ msg -> modifyIORef' logs (LBS.fromStrict (FL.fromLogStr msg) :) - } - tunnelRequest = connectRequestFor "127.0.0.1" targetPort HT.http20 - failAfterResponse _ = ioError (userError "client stream closed after connect") - result <- try (httpConnectProxy loggingSettings fallback tunnelRequest failAfterResponse) :: IO (Either SomeException ResponseReceived) - case result of - Left _ -> return () - Right _ -> expectationFailure "response failure was swallowed" - renderedLogs <- LBS.toStrict . LBS.concat . reverse <$> readIORef logs - renderedLogs `shouldNotSatisfy` BS8.isInfixOf "CONNECT upstream failure" + it "does not log upstream failure after an HTTP/2 tunnel response starts" $ + withTcpEchoServer $ \targetPort -> do + logs <- newIORef [] + let loggingSettings = authorizedSettings + { logger = \_ msg -> modifyIORef' logs (LBS.fromStrict (FL.fromLogStr msg) :) + } + tunnelRequest = connectRequestFor "127.0.0.1" targetPort HT.http20 + failAfterResponse _ = ioError (userError "client stream closed after connect") + result <- try (httpConnectProxy loggingSettings fallback tunnelRequest failAfterResponse) :: IO (Either SomeException ResponseReceived) + case result of + Left _ -> return () + Right _ -> expectationFailure "response failure was swallowed" + renderedLogs <- LBS.toStrict . LBS.concat . reverse <$> readIORef logs + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "CONNECT upstream failure" - it "does not log upstream failure when HTTP/2 cancels before the tunnel response starts" $ do - logs <- newIORef [] - let loggingSettings = authorizedSettings - { logger = \_ msg -> modifyIORef' logs (LBS.fromStrict (FL.fromLogStr msg) :) - } - cancelledBeforeResponse _ _ = throwIO ThreadKilled - respondOk _ = ioError (userError "respond should not be called") - result <- try (httpConnectProxyWith cancelledBeforeResponse loggingSettings fallback (connectRequestFor "127.0.0.1" 443 HT.http20) respondOk) :: IO (Either SomeException ResponseReceived) - case result of - Left _ -> return () - Right _ -> expectationFailure "pre-response cancellation was swallowed" - renderedLogs <- LBS.toStrict . LBS.concat . reverse <$> readIORef logs - renderedLogs `shouldNotSatisfy` BS8.isInfixOf "CONNECT upstream failure" + it "does not log upstream failure when HTTP/2 cancels before the tunnel response starts" $ do + logs <- newIORef [] + let loggingSettings = authorizedSettings + { logger = \_ msg -> modifyIORef' logs (LBS.fromStrict (FL.fromLogStr msg) :) + } + cancelledBeforeResponse _ _ = throwIO ThreadKilled + respondOk _ = ioError (userError "respond should not be called") + result <- try (httpConnectProxyWith cancelledBeforeResponse loggingSettings fallback (connectRequestFor "127.0.0.1" 443 HT.http20) respondOk) :: IO (Either SomeException ResponseReceived) + case result of + Left _ -> return () + Right _ -> expectationFailure "pre-response cancellation was swallowed" + renderedLogs <- LBS.toStrict . LBS.concat . reverse <$> readIORef logs + renderedLogs `shouldNotSatisfy` BS8.isInfixOf "CONNECT upstream failure" - describe "HTTP proxy fallback decisions" $ - it "falls through for non-proxy GET requests" $ do - response <- runProxyApp (httpProxy authRequiredSettings) defaultRequest - simpleStatus response `shouldBe` fallbackStatus - simpleBody response `shouldBe` fallbackBody + describe "HTTP proxy fallback decisions" $ + it "falls through for non-proxy GET requests" $ do + response <- runProxyApp (httpProxy authRequiredSettings) defaultRequest + simpleStatus response `shouldBe` fallbackStatus + simpleBody response `shouldBe` fallbackBody - describe "HTTP proxy target parsing" $ do - it "selects raw absolute-URI proxy targets with default ports" $ - selectHttpProxyTarget rawProxyRequest - `shouldBe` Just HttpProxyTarget - { httpProxyTargetHost = "example.com" - , httpProxyTargetPort = 80 - , httpProxyTargetRawPath = "/resource" - } + describe "HTTP proxy target parsing" $ do + it "selects raw absolute-URI proxy targets with default ports" $ + selectHttpProxyTarget rawProxyRequest + `shouldBe` Just HttpProxyTarget + { httpProxyTargetHost = "example.com" + , httpProxyTargetPort = 80 + , httpProxyTargetRawPath = "/resource" + } - it "preserves bracketed IPv6 proxy targets without explicit ports" $ - selectHttpProxyTarget rawProxyRequest { rawPathInfo = "http://[::1]/resource" } - `shouldBe` Just HttpProxyTarget - { httpProxyTargetHost = "[::1]" - , httpProxyTargetPort = 80 - , httpProxyTargetRawPath = "/resource" - } + it "preserves bracketed IPv6 proxy targets without explicit ports" $ + selectHttpProxyTarget rawProxyRequest { rawPathInfo = "http://[::1]/resource" } + `shouldBe` Just HttpProxyTarget + { httpProxyTargetHost = "[::1]" + , httpProxyTargetPort = 80 + , httpProxyTargetRawPath = "/resource" + } - it "treats HTTP/2 proxy scheme values case-insensitively" $ - selectHttpProxyTarget http2ProxyRequest { requestHeaders = [("X-Scheme", "HTTP")] } - `shouldBe` Just HttpProxyTarget - { httpProxyTargetHost = "example.com" - , httpProxyTargetPort = 80 - , httpProxyTargetRawPath = "/resource" - } + it "treats HTTP/2 proxy scheme values case-insensitively" $ + selectHttpProxyTarget http2ProxyRequest { requestHeaders = [("X-Scheme", "HTTP")] } + `shouldBe` Just HttpProxyTarget + { httpProxyTargetHost = "example.com" + , httpProxyTargetPort = 80 + , httpProxyTargetRawPath = "/resource" + } - it "rejects malformed explicit ports in raw absolute-URI requests" $ - selectHttpProxyTarget rawProxyRequest { rawPathInfo = "http://example.com:not-a-port/resource" } - `shouldBe` Nothing + it "rejects malformed explicit ports in raw absolute-URI requests" $ + selectHttpProxyTarget rawProxyRequest { rawPathInfo = "http://example.com:not-a-port/resource" } + `shouldBe` Nothing - it "rejects malformed explicit ports in Host-header proxy requests" $ - selectHttpProxyTarget hostHeaderProxyRequest { requestHeaderHost = Just "example.com:not-a-port" } - `shouldBe` Nothing + it "rejects malformed explicit ports in Host-header proxy requests" $ + selectHttpProxyTarget hostHeaderProxyRequest { requestHeaderHost = Just "example.com:not-a-port" } + `shouldBe` Nothing - it "rejects HTTP/2 proxy requests without a Host header" $ - selectHttpProxyTarget http2ProxyRequest { requestHeaderHost = Nothing } - `shouldBe` Nothing + it "rejects HTTP/2 proxy requests without a Host header" $ + selectHttpProxyTarget http2ProxyRequest { requestHeaderHost = Nothing } + `shouldBe` Nothing - it "renders HTTP proxy authorities without the default port" $ do - renderHttpProxyAuthority (HttpProxyTarget "example.com" 80 "/") - `shouldBe` "example.com" - renderHttpProxyAuthority (HttpProxyTarget "example.com" 443 "/") - `shouldBe` "example.com:443" - renderHttpProxyAuthority (HttpProxyTarget "example.com" 8080 "/") - `shouldBe` "example.com:8080" + it "renders HTTP proxy authorities without the default port" $ do + renderHttpProxyAuthority (HttpProxyTarget "example.com" 80 "/") + `shouldBe` "example.com" + renderHttpProxyAuthority (HttpProxyTarget "example.com" 443 "/") + `shouldBe` "example.com:443" + renderHttpProxyAuthority (HttpProxyTarget "example.com" 8080 "/") + `shouldBe` "example.com:8080" - describe "HTTP proxy upstream requests" $ - it "uses absolute URI authority for Host and strips proxy boundary headers" $ - withRawHttpServer observeRawProxyRequestBody $ \port -> do - let authority = "127.0.0.1:" <> BS8.pack (show port) - responseBody = LBS8.lines . simpleBody - proxiedReq = defaultRequest - { requestMethod = "GET" - , rawPathInfo = "http://" <> authority <> "/resource" - , requestHeaderHost = Just "evil.example" - , requestHeaders = - [ (HT.hHost, "evil.example") - , (HT.hProxyAuthorization, "Basic " <> B64.encode "alice:secret") - , ("Forwarded", "for=203.0.113.7") - , ("X-Forwarded-For", "203.0.113.7") - , ("Proxy-Connection", "keep-alive") - , ("cf-ray", "abc123") - , ("X-Real-IP", "203.0.113.7") - , ("User-Agent", "hprox-test") - ] - } - response <- runProxyApp (httpProxy authorizedSettings) proxiedReq - simpleStatus response `shouldBe` HT.status200 - responseBody response - `shouldBe` [ LBS.fromStrict authority - , LBS.fromStrict authority - , "False" - , "False" - , "False" - , "False" - , "False" - , "True" - ] + describe "HTTP proxy upstream requests" $ + it "uses absolute URI authority for Host and strips proxy boundary headers" $ + withRawHttpServer observeRawProxyRequestBody $ \port -> do + let authority = "127.0.0.1:" <> BS8.pack (show port) + responseBody = LBS8.lines . simpleBody + proxiedReq = + defaultRequest + { requestMethod = "GET" + , rawPathInfo = "http://" <> authority <> "/resource" + , requestHeaderHost = Just "evil.example" + , requestHeaders = + [ (HT.hHost, "evil.example") + , (HT.hProxyAuthorization, "Basic " <> B64.encode "alice:secret") + , ("Forwarded", "for=203.0.113.7") + , ("X-Forwarded-For", "203.0.113.7") + , ("Proxy-Connection", "keep-alive") + , ("cf-ray", "abc123") + , ("X-Real-IP", "203.0.113.7") + , ("User-Agent", "hprox-test") + ] + } + response <- runProxyApp (httpProxy authorizedSettings) proxiedReq + simpleStatus response `shouldBe` HT.status200 + responseBody response `shouldBe` + [ LBS.fromStrict authority + , LBS.fromStrict authority + , "False" + , "False" + , "False" + , "False" + , "False" + , "True" + ] -- Keep proxy upstream tests independent of Warp's Windows accept loop. withRawHttpServer :: (BS.ByteString -> LBS.ByteString) -> (Int -> IO a) -> IO a withRawHttpServer responseBody action = - bracket open cleanup run + bracket open cleanup run where open = do - accepted <- newIORef Nothing - sock <- openTcpServerSocket - return (sock, accepted) + accepted <- newIORef Nothing + sock <- openTcpServerSocket + return (sock, accepted) cleanup (sock, accepted) = do - closeIgnoringErrors sock - readIORef accepted >>= mapM_ closeIgnoringErrors + closeIgnoringErrors sock + readIORef accepted >>= mapM_ closeIgnoringErrors run server@(sock, _) = do - done <- newEmptyMVar - _ <- forkIO $ try (acceptAndRespond server) >>= putMVar done - result <- action . fromIntegral =<< socketPort sock - serverResult <- timeout 2000000 (takeMVar done) - case serverResult of - Just (Left ex) -> throwIO (ex :: SomeException) - _ -> return result + done <- newEmptyMVar + _ <- forkIO $ try (acceptAndRespond server) >>= putMVar done + result <- action . fromIntegral =<< socketPort sock + serverResult <- timeout 2000000 (takeMVar done) + case serverResult of + Just (Left ex) -> throwIO (ex :: SomeException) + _ -> return result acceptAndRespond (sock, accepted) = - bracket (acceptClient sock accepted) closeIgnoringErrors $ \conn -> do - requestBytes <- recvHttpRequest conn - sendHttpResponse conn $ responseBody requestBytes + bracket (acceptClient sock accepted) closeIgnoringErrors $ \conn -> do + requestBytes <- recvHttpRequest conn + sendHttpResponse conn $ responseBody requestBytes acceptClient sock accepted = do - (conn, _) <- accept sock - writeIORef accepted (Just conn) - return conn + (conn, _) <- accept sock + writeIORef accepted (Just conn) + return conn openTcpServerSocket :: IO Socket openTcpServerSocket = bracketOnError open closeIgnoringErrors $ \sock -> do - setSocketOption sock ReuseAddr 1 - bind sock (SockAddrInet 0 loopbackAddress) - listen sock (max 2048 maxListenQueue) - return sock + setSocketOption sock ReuseAddr 1 + bind sock (SockAddrInet 0 loopbackAddress) + listen sock (max 2048 maxListenQueue) + return sock where open = socket AF_INET Stream defaultProtocol @@ -265,43 +266,43 @@ recvHttpRequest conn = go BS.empty where go received - | "\r\n\r\n" `BS.isInfixOf` received = return received - | BS.length received > 65536 = ioError $ userError "upstream HTTP request headers exceeded test limit" - | otherwise = do - chunk <- recvWithTimeout conn - if BS.null chunk + | "\r\n\r\n" `BS.isInfixOf` received = return received + | BS.length received > 65536 = ioError $ userError "upstream HTTP request headers exceeded test limit" + | otherwise = do + chunk <- recvWithTimeout conn + if BS.null chunk then ioError $ userError "upstream HTTP request ended before headers completed" else go (received <> chunk) sendHttpResponse :: Socket -> LBS.ByteString -> IO () sendHttpResponse conn body = - let strictBody = LBS.toStrict body - in SocketBS.sendAll conn $ BS8.concat - [ "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nContent-Length: " - , BS8.pack (show $ BS.length strictBody) - , "\r\nConnection: close\r\n\r\n" - , strictBody - ] + let strictBody = LBS.toStrict body + in SocketBS.sendAll conn $ BS8.concat + [ "HTTP/1.1 200 OK\r\nContent-Type: text/plain\r\nContent-Length: " + , BS8.pack (show $ BS.length strictBody) + , "\r\nConnection: close\r\n\r\n" + , strictBody + ] closeIgnoringErrors :: Socket -> IO () closeIgnoringErrors sock = do - closed <- try (close sock) :: IO (Either IOException ()) - case closed of - Left _ -> return () - Right () -> return () + closed <- try (close sock) :: IO (Either IOException ()) + case closed of + Left _ -> return () + Right () -> return () observeRawProxyRequestBody :: BS.ByteString -> LBS.ByteString observeRawProxyRequestBody requestBytes = - LBS8.unlines - [ LBS.fromStrict $ headerValue HT.hHost - , LBS.fromStrict $ headerValue HT.hHost - , LBS8.pack $ show $ hasHeader HT.hProxyAuthorization - , LBS8.pack $ show $ hasHeader "Forwarded" - , LBS8.pack $ show $ hasHeader "X-Forwarded-For" - , LBS8.pack $ show $ hasHeader "Proxy-Connection" - , LBS8.pack $ show $ hasHeader "cf-ray" - , LBS8.pack $ show $ hasHeader "User-Agent" - ] + LBS8.unlines + [ LBS.fromStrict $ headerValue HT.hHost + , LBS.fromStrict $ headerValue HT.hHost + , LBS8.pack $ show $ hasHeader HT.hProxyAuthorization + , LBS8.pack $ show $ hasHeader "Forwarded" + , LBS8.pack $ show $ hasHeader "X-Forwarded-For" + , LBS8.pack $ show $ hasHeader "Proxy-Connection" + , LBS8.pack $ show $ hasHeader "cf-ray" + , LBS8.pack $ show $ hasHeader "User-Agent" + ] where headers = mapMaybe parseHeader $ takeWhile (not . BS.null) $ drop 1 $ map trimCR $ BS8.lines requestBytes normalizedHeaders = [(CI.mk name, value) | (name, value) <- headers] @@ -310,47 +311,46 @@ hasHeader name = lookup name normalizedHeaders /= Nothing parseHeader line = - let (name, rest) = BS8.break (== ':') line - in if BS.null rest - then Nothing - else Just (name, BS8.dropWhile (== ' ') $ BS.drop 1 rest) + let (name, rest) = BS8.break (== ':') line + in if BS.null rest + then Nothing + else Just (name, BS8.dropWhile (== ' ') $ BS.drop 1 rest) trimCR line - | "\r" `BS.isSuffixOf` line = BS.init line - | otherwise = line + | "\r" `BS.isSuffixOf` line = BS.init line + | otherwise = line runProxyApp :: (HC.Manager -> Middleware) -> Request -> IO SResponse - runProxyApp middleware req = do - manager <- HC.newManager $ - HC.managerSetProxy HC.noProxy HC.defaultManagerSettings - { HC.managerIdleConnectionCount = 0 - , HC.managerResponseTimeout = HC.responseTimeoutMicro 2000000 - } - runSession (srequest $ SRequest req "") (middleware manager fallback) + manager <- HC.newManager $ + HC.managerSetProxy HC.noProxy HC.defaultManagerSettings + { HC.managerIdleConnectionCount = 0 + , HC.managerResponseTimeout = HC.responseTimeoutMicro 2000000 + } + runSession (srequest $ SRequest req "") (middleware manager fallback) runConnectApp :: ProxySettings -> Request -> IO SResponse runConnectApp pset req = runSession (srequest $ SRequest req "") (httpConnectProxy pset fallback) rawProxyRequest :: Request rawProxyRequest = defaultRequest - { requestMethod = "GET" - , rawPathInfo = "http://example.com/resource" - , requestHeaderHost = Just "example.com" - } + { requestMethod = "GET" + , rawPathInfo = "http://example.com/resource" + , requestHeaderHost = Just "example.com" + } rawProxyRequestWithAuth :: BS8.ByteString -> Request rawProxyRequestWithAuth auth = rawProxyRequest - { requestHeaders = [(HT.hProxyAuthorization, auth)] - } + { requestHeaders = [(HT.hProxyAuthorization, auth)] + } proxyRequestForPort :: Int -> BS8.ByteString -> Request proxyRequestForPort port auth = - let authority = "127.0.0.1:" <> BS8.pack (show port) - in (rawProxyRequestWithAuth auth) - { rawPathInfo = "http://" <> authority <> "/resource" - , requestHeaderHost = Just authority - } + let authority = "127.0.0.1:" <> BS8.pack (show port) + in (rawProxyRequestWithAuth auth) + { rawPathInfo = "http://" <> authority <> "/resource" + , requestHeaderHost = Just authority + } basicAliceSecret :: BS8.ByteString basicAliceSecret = basicCredential "alice:secret" @@ -360,125 +360,124 @@ hostHeaderProxyRequest :: Request hostHeaderProxyRequest = defaultRequest - { requestMethod = "GET" - , rawPathInfo = "/resource" - , requestHeaderHost = Just "example.com" - , requestHeaders = [("Proxy-Connection", "keep-alive")] - } + { requestMethod = "GET" + , rawPathInfo = "/resource" + , requestHeaderHost = Just "example.com" + , requestHeaders = [("Proxy-Connection", "keep-alive")] + } http2ProxyRequest :: Request http2ProxyRequest = defaultRequest - { requestMethod = "GET" - , rawPathInfo = "/resource" - , requestHeaderHost = Just "example.com" - , requestHeaders = [("X-Scheme", "http")] - , httpVersion = HT.http20 - , isSecure = True - } + { requestMethod = "GET" + , rawPathInfo = "/resource" + , requestHeaderHost = Just "example.com" + , requestHeaders = [("X-Scheme", "http")] + , httpVersion = HT.http20 + , isSecure = True + } connectRequest :: Request connectRequest = defaultRequest - { requestMethod = "CONNECT" - , rawPathInfo = "example.com:443" - , requestHeaderHost = Just "example.com:443" - } + { requestMethod = "CONNECT" + , rawPathInfo = "example.com:443" + , requestHeaderHost = Just "example.com:443" + } connectRequestFor :: BS8.ByteString -> Int -> HT.HttpVersion -> Request connectRequestFor host port version = - let authority = host <> ":" <> BS8.pack (show port) - in connectRequest - { rawPathInfo = authority - , requestHeaderHost = Just authority - , requestHeaders = [(HT.hProxyAuthorization, basicAliceSecret)] - , httpVersion = version - } + let authority = host <> ":" <> BS8.pack (show port) + in connectRequest + { rawPathInfo = authority + , requestHeaderHost = Just authority + , requestHeaders = [(HT.hProxyAuthorization, basicAliceSecret)] + , httpVersion = version + } getFreePort :: IO Int getFreePort = bracket open close socketPortInt where open = do - sock <- socket AF_INET Stream defaultProtocol - setSocketOption sock ReuseAddr 1 - bind sock (SockAddrInet 0 loopbackAddress) - return sock + sock <- socket AF_INET Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bind sock (SockAddrInet 0 loopbackAddress) + return sock socketPortInt sock = fromIntegral <$> socketPort sock withTcpEchoServer :: (Int -> IO a) -> IO a withTcpEchoServer action = do - accepted <- newIORef Nothing - bracket (open accepted) cleanup run + accepted <- newIORef Nothing + bracket (open accepted) cleanup run where open accepted = do - sock <- openTcpServerSocket - return (sock, accepted) + sock <- openTcpServerSocket + return (sock, accepted) cleanup (sock, accepted) = do - closeIgnoringErrors sock - readIORef accepted >>= mapM_ closeIgnoringErrors + closeIgnoringErrors sock + readIORef accepted >>= mapM_ closeIgnoringErrors run server@(sock, _) = - withAsync (acceptAndEcho server) $ \_ -> - (action . fromIntegral =<< socketPort sock) `finally` cleanup server + withAsync (acceptAndEcho server) $ \_ -> + (action . fromIntegral =<< socketPort sock) `finally` cleanup server acceptAndEcho (sock, accepted) = - bracket (acceptClient sock accepted) closeIgnoringErrors echoLoop + bracket (acceptClient sock accepted) closeIgnoringErrors echoLoop acceptClient sock accepted = do - (conn, _) <- accept sock - writeIORef accepted (Just conn) - return conn + (conn, _) <- accept sock + writeIORef accepted (Just conn) + return conn echoLoop conn = do - bs <- SocketBS.recv conn 4096 - unless (BS8.null bs) $ do - SocketBS.sendAll conn bs - echoLoop conn - + bs <- SocketBS.recv conn 4096 + unless (BS8.null bs) $ do + SocketBS.sendAll conn bs + echoLoop conn -- Exercise the HTTP/1 raw response path without running a nested Warp server. rawConnectRoundTrip :: IO BS8.ByteString rawConnectRoundTrip = do - outbound <- newIORef [] - clientChunks <- newIORef ["ping", ""] - let targetHost = "127.0.0.1" - targetPort = 18443 - runTCPClient settings app = do - CN.getHost settings `shouldBe` targetHost - CN.getPort settings `shouldBe` targetPort - inbound <- newEmptyMVar - app AppData - { appRead' = takeMVar inbound - , appWrite' = \bytes -> do - putMVar inbound bytes - putMVar inbound BS.empty - , appSockAddr' = SockAddrInet 0 loopbackAddress - , appLocalAddr' = Nothing - , appCloseConnection' = return () - , appRawSocket' = Nothing - } - nextClientChunk = - atomicModifyIORef' clientChunks $ \chunks -> - case chunks of - [] -> ([], BS.empty) - x : xs -> (xs, x) - respondRaw (ResponseRaw raw _) = do - raw nextClientChunk (\bytes -> modifyIORef' outbound (bytes :)) - return ResponseReceived - respondRaw _ = expectationFailure "expected HTTP/1 raw CONNECT response" >> return ResponseReceived - _ <- httpConnectProxyWith runTCPClient authorizedSettings fallback (connectRequestFor targetHost targetPort HT.http11) respondRaw - sent <- BS.concat . reverse <$> readIORef outbound - sent `shouldSatisfy` BS8.isPrefixOf "HTTP/1.1 200" - case BS.breakSubstring "\r\n\r\n" sent of - (_, body) | not (BS.null body) -> return $ BS.drop 4 body - _ -> expectationFailure "raw CONNECT response did not contain an HTTP header terminator" >> return BS.empty + outbound <- newIORef [] + clientChunks <- newIORef ["ping", ""] + let targetHost = "127.0.0.1" + targetPort = 18443 + runTCPClient settings app = do + CN.getHost settings `shouldBe` targetHost + CN.getPort settings `shouldBe` targetPort + inbound <- newEmptyMVar + app AppData + { appRead' = takeMVar inbound + , appWrite' = \bytes -> do + putMVar inbound bytes + putMVar inbound BS.empty + , appSockAddr' = SockAddrInet 0 loopbackAddress + , appLocalAddr' = Nothing + , appCloseConnection' = return () + , appRawSocket' = Nothing + } + nextClientChunk = + atomicModifyIORef' clientChunks $ \chunks -> + case chunks of + [] -> ([], BS.empty) + x : xs -> (xs, x) + respondRaw (ResponseRaw raw _) = do + raw nextClientChunk (\bytes -> modifyIORef' outbound (bytes :)) + return ResponseReceived + respondRaw _ = expectationFailure "expected HTTP/1 raw CONNECT response" >> return ResponseReceived + _ <- httpConnectProxyWith runTCPClient authorizedSettings fallback (connectRequestFor targetHost targetPort HT.http11) respondRaw + sent <- BS.concat . reverse <$> readIORef outbound + sent `shouldSatisfy` BS8.isPrefixOf "HTTP/1.1 200" + case BS.breakSubstring "\r\n\r\n" sent of + (_, body) | not (BS.null body) -> return $ BS.drop 4 body + _ -> expectationFailure "raw CONNECT response did not contain an HTTP header terminator" >> return BS.empty recvWithTimeout :: Socket -> IO BS8.ByteString recvWithTimeout sock = do - received <- timeout 2000000 (SocketBS.recv sock 4096) - case received of - Just bytes -> return bytes - Nothing -> ioError $ userError "timed out waiting for proxy socket response" + received <- timeout 2000000 (SocketBS.recv sock 4096) + case received of + Just bytes -> return bytes + Nothing -> ioError $ userError "timed out waiting for proxy socket response" loopbackAddress :: HostAddress loopbackAddress = tupleToHostAddress (127, 0, 0, 1) @@ -494,28 +493,28 @@ authRequiredSettings :: ProxySettings authRequiredSettings = baseSettings - { proxyAuth = Just (const False) - } + { proxyAuth = Just (const False) + } hiddenAuthSettings :: ProxySettings hiddenAuthSettings = authRequiredSettings - { hideProxyAuth = True - } + { hideProxyAuth = True + } authorizedSettings :: ProxySettings authorizedSettings = baseSettings - { proxyAuth = Just (== "alice:secret") - } + { proxyAuth = Just (== "alice:secret") + } baseSettings :: ProxySettings baseSettings = ProxySettings - { proxyAuth = Nothing - , passPrompt = Just "hprox" - , wsRemote = Nothing - , revRemoteMap = [] - , hideProxyAuth = False - , naivePadding = False - , acmeThumbprint = Nothing - , logger = \_ _ -> return () - } + { proxyAuth = Nothing + , passPrompt = Just "hprox" + , wsRemote = Nothing + , revRemoteMap = [] + , hideProxyAuth = False + , naivePadding = False + , acmeThumbprint = Nothing + , logger = \_ _ -> return () + } diff --git a/test/Network/HProx/PureSpec.hs b/test/Network/HProx/PureSpec.hs --- a/test/Network/HProx/PureSpec.hs +++ b/test/Network/HProx/PureSpec.hs @@ -15,67 +15,67 @@ spec :: Spec spec = do - describe "parseHostPort" $ do - it "parses a valid host and port" $ - parseHostPort "example.com:443" `shouldBe` Just ("example.com", 443) + describe "parseHostPort" $ do + it "parses a valid host and port" $ + parseHostPort "example.com:443" `shouldBe` Just ("example.com", 443) - it "uses the last colon as the port separator" $ - parseHostPort "example.com:proxy:8080" `shouldBe` Just ("example.com:proxy", 8080) + it "uses the last colon as the port separator" $ + parseHostPort "example.com:proxy:8080" `shouldBe` Just ("example.com:proxy", 8080) - it "accepts an empty host portion" $ - parseHostPort ":123" `shouldBe` Just ("", 123) + it "accepts an empty host portion" $ + parseHostPort ":123" `shouldBe` Just ("", 123) - it "rejects missing, invalid, trailing, and out-of-range ports" $ - map parseHostPort ["example.com", "example.com:http", "example.com:80x", "example.com:0", "example.com:65536", "example.com:"] - `shouldBe` replicate 6 Nothing + it "rejects missing, invalid, trailing, and out-of-range ports" $ + map parseHostPort ["example.com", "example.com:http", "example.com:80x", "example.com:0", "example.com:65536", "example.com:"] + `shouldBe` replicate 6 Nothing - describe "parseHostPortWithDefault" $ do - it "returns an explicit port when parsing succeeds" $ - parseHostPortWithDefault 80 "example.com:443" `shouldBe` ("example.com", 443) + describe "parseHostPortWithDefault" $ do + it "returns an explicit port when parsing succeeds" $ + parseHostPortWithDefault 80 "example.com:443" `shouldBe` ("example.com", 443) - it "returns the original input and default port when parsing fails" $ - parseHostPortWithDefault 80 "example.com:not-a-port" `shouldBe` ("example.com:not-a-port", 80) + it "returns the original input and default port when parsing fails" $ + parseHostPortWithDefault 80 "example.com:not-a-port" `shouldBe` ("example.com:not-a-port", 80) - describe "passwordReader" $ do - it "parses plaintext password lines" $ - passwordReader "user:pass" `shouldBe` Just ("user", PlainText "pass") + describe "passwordReader" $ do + it "parses plaintext password lines" $ + passwordReader "user:pass" `shouldBe` Just ("user", PlainText "pass") - it "parses salted password lines by base64-decoding salt and hash" $ - passwordReader "user:c2FsdA==:aGFzaA==" `shouldBe` Just ("user", Salted "salt" "hash") + it "parses salted password lines by base64-decoding salt and hash" $ + passwordReader "user:c2FsdA==:aGFzaA==" `shouldBe` Just ("user", Salted "salt" "hash") - it "rejects invalid salted and over-split password lines" $ - map passwordReader ["user:not-base64:also-not-base64", "user:pass:extra:field"] - `shouldBe` [Nothing, Nothing] + it "rejects invalid salted and over-split password lines" $ + map passwordReader ["user:not-base64:also-not-base64", "user:pass:extra:field"] + `shouldBe` [Nothing, Nothing] - describe "passwordWriter" $ - it "writes salted password lines with base64 salt and hash" $ - passwordWriter "user" (PasswordSalted "salt" "hash") `shouldBe` "user:c2FsdA==:aGFzaA==" + describe "passwordWriter" $ + it "writes salted password lines with base64 salt and hash" $ + passwordWriter "user" (PasswordSalted "salt" "hash") `shouldBe` "user:c2FsdA==:aGFzaA==" - describe "hashPasswordWithSalt" $ do - it "returns a typed failure when Argon2 rejects hashing parameters" $ - case hashPasswordWithSalt "" (PlainText "pass") of - Left (PasswordHashError msg) -> msg `shouldContain` "unable to hash password with salt" - Right _ -> expectationFailure "expected typed hash failure" + describe "hashPasswordWithSalt" $ do + it "returns a typed failure when Argon2 rejects hashing parameters" $ + case hashPasswordWithSalt "" (PlainText "pass") of + Left (PasswordHashError msg) -> msg `shouldContain` "unable to hash password with salt" + Right _ -> expectationFailure "expected typed hash failure" - it "keeps already salted passwords without rehashing" $ - hashPasswordWithSalt "" (Salted "salt" "hash") `shouldBe` Right (PasswordSalted "salt" "hash") + it "keeps already salted passwords without rehashing" $ + hashPasswordWithSalt "" (Salted "salt" "hash") `shouldBe` Right (PasswordSalted "salt" "hash") - describe "logLevelReader" $ do - it "parses all current log levels" $ - map logLevelReader ["trace", "debug", "info", "warn", "error", "none"] - `shouldBe` map Just [TRACE, DEBUG, INFO, WARN, ERROR, NONE] + describe "logLevelReader" $ do + it "parses all current log levels" $ + map logLevelReader ["trace", "debug", "info", "warn", "error", "none"] + `shouldBe` map Just [TRACE, DEBUG, INFO, WARN, ERROR, NONE] - it "rejects unknown log levels and different casing" $ - map logLevelReader ["", "warning", "INFO"] `shouldBe` replicate 3 Nothing + it "rejects unknown log levels and different casing" $ + map logLevelReader ["", "warning", "INFO"] `shouldBe` replicate 3 Nothing - describe "parseLogOutput" $ - it "preserves current log destination parsing policy" $ - map parseLogOutput ["none", "stdout", "stderr", "hprox.log"] - `shouldBe` [LogOutputNone, LogOutputStdout, LogOutputStderr, LogOutputFile "hprox.log"] + describe "parseLogOutput" $ + it "preserves current log destination parsing policy" $ + map parseLogOutput ["none", "stdout", "stderr", "hprox.log"] + `shouldBe` [LogOutputNone, LogOutputStdout, LogOutputStderr, LogOutputFile "hprox.log"] - describe "splitBy" $ do - it "preserves empty segments between, before, and after separators" $ - NE.toList (splitBy ':' ":a::b:") `shouldBe` ["", "a", "", "b", ""] + describe "splitBy" $ do + it "preserves empty segments between, before, and after separators" $ + NE.toList (splitBy ':' ":a::b:") `shouldBe` ["", "a", "", "b", ""] - it "returns one empty segment for empty input" $ - NE.toList (splitBy ':' "") `shouldBe` [""] + it "returns one empty segment for empty input" $ + NE.toList (splitBy ':' "") `shouldBe` [""] diff --git a/test/Network/HProx/RouteSpec.hs b/test/Network/HProx/RouteSpec.hs --- a/test/Network/HProx/RouteSpec.hs +++ b/test/Network/HProx/RouteSpec.hs @@ -12,97 +12,97 @@ spec :: Spec spec = - describe "ReverseRoute" $ do - it "converts and normalizes from the public Config reverse-route tuple shape" $ do - fromReverseRouteTuple (Just "example.com", "/api/", "backend:80") - `shouldBe` ReverseRoute - { routeHost = Just "example.com" - , routePrefix = "/api" - , routeUpstream = "backend:80" - } - routePrefix (fromReverseRouteTuple (Nothing, "api", "backend:80")) `shouldBe` "/api" - routePrefix (fromReverseRouteTuple (Nothing, "/", "backend:80")) `shouldBe` "/" + describe "ReverseRoute" $ do + it "converts and normalizes from the public Config reverse-route tuple shape" $ do + fromReverseRouteTuple (Just "example.com", "/api/", "backend:80") + `shouldBe` ReverseRoute + { routeHost = Just "example.com" + , routePrefix = "/api" + , routeUpstream = "backend:80" + } + routePrefix (fromReverseRouteTuple (Nothing, "api", "backend:80")) `shouldBe` "/api" + routePrefix (fromReverseRouteTuple (Nothing, "/", "backend:80")) `shouldBe` "/" - it "sorts domain-specific routes before catch-all routes and longer prefixes first" $ do - let catchAllLong = ReverseRoute Nothing "/longer/" "catch-long:80" - catchAllShort = ReverseRoute Nothing "/" "catch-short:80" - hostShort = ReverseRoute (Just "example.com") "/" "host-short:80" - hostLong = ReverseRoute (Just "example.com") "/api/" "host-long:80" - sortReverseRoutes [catchAllShort, hostShort, catchAllLong, hostLong] - `shouldBe` [hostLong, hostShort, catchAllLong, catchAllShort] + it "sorts domain-specific routes before catch-all routes and longer prefixes first" $ do + let catchAllLong = ReverseRoute Nothing "/longer/" "catch-long:80" + catchAllShort = ReverseRoute Nothing "/" "catch-short:80" + hostShort = ReverseRoute (Just "example.com") "/" "host-short:80" + hostLong = ReverseRoute (Just "example.com") "/api/" "host-long:80" + sortReverseRoutes [catchAllShort, hostShort, catchAllLong, hostLong] + `shouldBe` [hostLong, hostShort, catchAllLong, catchAllShort] - it "matches hostless routes against any request host" $ do - let route = ReverseRoute Nothing "/" "backend:80" - hostMatches route Nothing `shouldBe` True - hostMatches route (Just "example.com") `shouldBe` True + it "matches hostless routes against any request host" $ do + let route = ReverseRoute Nothing "/" "backend:80" + hostMatches route Nothing `shouldBe` True + hostMatches route (Just "example.com") `shouldBe` True - it "matches host-specific routes case-insensitively" $ do - let route = ReverseRoute (Just "example.com") "/" "backend:80" - hostMatches route Nothing `shouldBe` False - hostMatches route (Just "example.com") `shouldBe` True - hostMatches route (Just "EXAMPLE.com") `shouldBe` True - hostMatches route (Just "other.example") `shouldBe` False + it "matches host-specific routes case-insensitively" $ do + let route = ReverseRoute (Just "example.com") "/" "backend:80" + hostMatches route Nothing `shouldBe` False + hostMatches route (Just "example.com") `shouldBe` True + hostMatches route (Just "EXAMPLE.com") `shouldBe` True + hostMatches route (Just "other.example") `shouldBe` False - it "matches prefixes on path boundaries" $ do - let route = ReverseRoute Nothing "/api" "backend:80" - prefixMatches route "/api" `shouldBe` True - prefixMatches route "/api/v1" `shouldBe` True - prefixMatches route "/apiary" `shouldBe` False - prefixMatches route "/apix" `shouldBe` False - prefixMatches route "/other" `shouldBe` False + it "matches prefixes on path boundaries" $ do + let route = ReverseRoute Nothing "/api" "backend:80" + prefixMatches route "/api" `shouldBe` True + prefixMatches route "/api/v1" `shouldBe` True + prefixMatches route "/apiary" `shouldBe` False + prefixMatches route "/apix" `shouldBe` False + prefixMatches route "/other" `shouldBe` False - it "finds the first matching route after current route sorting" $ do - let catchAll = ReverseRoute Nothing "/api/" "catch-all:80" - shorterHost = ReverseRoute (Just "example.com") "/" "shorter-host:80" - longerHost = ReverseRoute (Just "example.com") "/api/" "longer-host:80" - findMatchingRoute [catchAll, shorterHost, longerHost] (Just "EXAMPLE.com:8080") "/api/users" - `shouldBe` Just longerHost + it "finds the first matching route after current route sorting" $ do + let catchAll = ReverseRoute Nothing "/api/" "catch-all:80" + shorterHost = ReverseRoute (Just "example.com") "/" "shorter-host:80" + longerHost = ReverseRoute (Just "example.com") "/api/" "longer-host:80" + findMatchingRoute [catchAll, shorterHost, longerHost] (Just "EXAMPLE.com:8080") "/api/users" + `shouldBe` Just longerHost - it "uses hostless routes for any request host when no host-specific route matches" $ do - let catchAll = ReverseRoute Nothing "/api/" "catch-all:80" - hostRoute = ReverseRoute (Just "example.com") "/api/" "host:80" - findMatchingRoute [catchAll, hostRoute] (Just "other.example") "/api/users" - `shouldBe` Just catchAll + it "uses hostless routes for any request host when no host-specific route matches" $ do + let catchAll = ReverseRoute Nothing "/api/" "catch-all:80" + hostRoute = ReverseRoute (Just "example.com") "/api/" "host:80" + findMatchingRoute [catchAll, hostRoute] (Just "other.example") "/api/users" + `shouldBe` Just catchAll - it "does not match host-specific routes without a request host" $ do - let route = ReverseRoute (Just "example.com") "/api/" "host:80" - findMatchingRoute [route] Nothing "/api/users" `shouldBe` Nothing + it "does not match host-specific routes without a request host" $ do + let route = ReverseRoute (Just "example.com") "/api/" "host:80" + findMatchingRoute [route] Nothing "/api/users" `shouldBe` Nothing - it "rewrites raw paths using normalized prefix boundaries" $ do - let route = fromReverseRouteTuple (Nothing, "/api", "backend:80") - exactRewrite = rewriteReverseProxyRequest route [] "/api" - nestedRewrite = rewriteReverseProxyRequest route [] "/api/users" - unmatchedRewrite = rewriteReverseProxyRequest route [] "/other" - rewriteRawPath exactRewrite `shouldBe` "/" - rewriteRawPath nestedRewrite `shouldBe` "/users" - rewriteRawPath unmatchedRewrite `shouldBe` "/other" + it "rewrites raw paths using normalized prefix boundaries" $ do + let route = fromReverseRouteTuple (Nothing, "/api", "backend:80") + exactRewrite = rewriteReverseProxyRequest route [] "/api" + nestedRewrite = rewriteReverseProxyRequest route [] "/api/users" + unmatchedRewrite = rewriteReverseProxyRequest route [] "/other" + rewriteRawPath exactRewrite `shouldBe` "/" + rewriteRawPath nestedRewrite `shouldBe` "/users" + rewriteRawPath unmatchedRewrite `shouldBe` "/other" - it "selects secure upstream behavior only for port 443" $ do - let secure = rewriteReverseProxyRequest (ReverseRoute Nothing "/" "secure.example:443") [] "/" - defaultPort = rewriteReverseProxyRequest (ReverseRoute Nothing "/" "plain.example") [] "/" - rewriteUpstream secure `shouldBe` "secure.example" - rewritePort secure `shouldBe` 443 - rewriteSecure secure `shouldBe` True - rewriteUpstream defaultPort `shouldBe` "plain.example" - rewritePort defaultPort `shouldBe` 80 - rewriteSecure defaultPort `shouldBe` False + it "selects secure upstream behavior only for port 443" $ do + let secure = rewriteReverseProxyRequest (ReverseRoute Nothing "/" "secure.example:443") [] "/" + defaultPort = rewriteReverseProxyRequest (ReverseRoute Nothing "/" "plain.example") [] "/" + rewriteUpstream secure `shouldBe` "secure.example" + rewritePort secure `shouldBe` 443 + rewriteSecure secure `shouldBe` True + rewriteUpstream defaultPort `shouldBe` "plain.example" + rewritePort defaultPort `shouldBe` 80 + rewriteSecure defaultPort `shouldBe` False - it "strips current proxy, forwarded, CDN, X-Real-IP, and X-Scheme headers" $ do - let route = ReverseRoute Nothing "/" "backend:80" - headers = - [ ("Proxy-Connection", "keep-alive") - , ("X-Forwarded-For", "127.0.0.1") - , ("cf-ray", "ray") - , ("cdn-loop", "loop") - , ("X-Real-IP", "127.0.0.1") - , ("X-Scheme", "https") - , ("Authorization", "keep") - ] - rewrite = rewriteReverseProxyRequest route headers "/" - rewriteHeaders rewrite `shouldBe` [("Host", "backend"), ("Authorization", "keep")] + it "strips current proxy, forwarded, CDN, X-Real-IP, and X-Scheme headers" $ do + let route = ReverseRoute Nothing "/" "backend:80" + headers = + [ ("Proxy-Connection", "keep-alive") + , ("X-Forwarded-For", "127.0.0.1") + , ("cf-ray", "ray") + , ("cdn-loop", "loop") + , ("X-Real-IP", "127.0.0.1") + , ("X-Scheme", "https") + , ("Authorization", "keep") + ] + rewrite = rewriteReverseProxyRequest route headers "/" + rewriteHeaders rewrite `shouldBe` [("Host", "backend"), ("Authorization", "keep")] - it "rewrites the request Host to the upstream host" $ do - let route = ReverseRoute Nothing "/" "backend.example:8080" - rewrite = rewriteReverseProxyRequest route [("Host", "original.example")] "/" - rewriteRequestHost rewrite `shouldBe` Just "backend.example" - rewriteHeaders rewrite `shouldBe` [("Host", "backend.example")] + it "rewrites the request Host to the upstream host" $ do + let route = ReverseRoute Nothing "/" "backend.example:8080" + rewrite = rewriteReverseProxyRequest route [("Host", "original.example")] "/" + rewriteRequestHost rewrite `shouldBe` Just "backend.example" + rewriteHeaders rewrite `shouldBe` [("Host", "backend.example")] diff --git a/test/Network/HProx/RuntimeSpec.hs b/test/Network/HProx/RuntimeSpec.hs --- a/test/Network/HProx/RuntimeSpec.hs +++ b/test/Network/HProx/RuntimeSpec.hs @@ -36,178 +36,178 @@ spec :: Spec spec = do - describe "RuntimeConfig" $ - it "normalizes log output and sorted reverse routes at the runtime boundary" $ - buildRuntimeConfig defaultConfig - { _log = "stderr" - , _rev = - [ (Nothing, "/", "catch:80") - , (Just "example.com", "/api/", "api:443") - ] - } `shouldBe` RuntimeConfig - { runtimeConfigLogOutput = LogOutputStderr - , runtimeConfigReverseRoutes = - [ ReverseRoute (Just "example.com") "/api" "api:443" - , ReverseRoute Nothing "/" "catch:80" - ] - , runtimeConfigReverseRouteTuples = - [ (Just "example.com", "/api/", "api:443") - , (Nothing, "/", "catch:80") - ] - } + describe "RuntimeConfig" $ + it "normalizes log output and sorted reverse routes at the runtime boundary" $ + buildRuntimeConfig defaultConfig + { _log = "stderr" + , _rev = + [ (Nothing, "/", "catch:80") + , (Just "example.com", "/api/", "api:443") + ] + } `shouldBe` RuntimeConfig + { runtimeConfigLogOutput = LogOutputStderr + , runtimeConfigReverseRoutes = + [ ReverseRoute (Just "example.com") "/api" "api:443" + , ReverseRoute Nothing "/" "catch:80" + ] + , runtimeConfigReverseRouteTuples = + [ (Just "example.com", "/api/", "api:443") + , (Nothing, "/", "catch:80") + ] + } - describe "runtime config validation" $ do - it "rejects direct Config listener ports outside the TCP port range" $ do - validateRuntimeConfig defaultConfig { _port = 0 } `shouldBe` Left "invalid --port: 0 (expected 1..65535)" - validateRuntimeConfig defaultConfig { _port = 65536 } `shouldBe` Left "invalid --port: 65536 (expected 1..65535)" + describe "runtime config validation" $ do + it "rejects direct Config listener ports outside the TCP port range" $ do + validateRuntimeConfig defaultConfig { _port = 0 } `shouldBe` Left "invalid --port: 0 (expected 1..65535)" + validateRuntimeConfig defaultConfig { _port = 65536 } `shouldBe` Left "invalid --port: 65536 (expected 1..65535)" #ifdef QUIC_ENABLED - it "rejects direct Config QUIC ports outside the UDP port range" $ do - validateRuntimeConfig defaultConfig { _quic = Just 0 } `shouldBe` Left "invalid --quic: 0 (expected 1..65535)" - validateRuntimeConfig defaultConfig { _quic = Just 65536 } `shouldBe` Left "invalid --quic: 65536 (expected 1..65535)" + it "rejects direct Config QUIC ports outside the UDP port range" $ do + validateRuntimeConfig defaultConfig { _quic = Just 0 } `shouldBe` Left "invalid --quic: 0 (expected 1..65535)" + validateRuntimeConfig defaultConfig { _quic = Just 65536 } `shouldBe` Left "invalid --quic: 65536 (expected 1..65535)" #endif - describe "Warp runtime settings" $ do - it "captures default bind, port, server name, and no-parse-path settings" $ - buildWarpRuntimePlan defaultConfig `shouldBe` WarpRuntimePlan - { runtimeBindHost = "*6" - , runtimePort = 3000 - , runtimeServerName = "hprox" - , runtimeNoParsePath = True - } + describe "Warp runtime settings" $ do + it "captures default bind, port, server name, and no-parse-path settings" $ + buildWarpRuntimePlan defaultConfig `shouldBe` WarpRuntimePlan + { runtimeBindHost = "*6" + , runtimePort = 3000 + , runtimeServerName = "hprox" + , runtimeNoParsePath = True + } - it "captures configured bind, port, and server name settings" $ - buildWarpRuntimePlan defaultConfig - { _bind = Just "127.0.0.1" - , _port = 8080 - , _name = "custom" - } `shouldBe` WarpRuntimePlan - { runtimeBindHost = "127.0.0.1" - , runtimePort = 8080 - , runtimeServerName = "custom" - , runtimeNoParsePath = True - } + it "captures configured bind, port, and server name settings" $ + buildWarpRuntimePlan defaultConfig + { _bind = Just "127.0.0.1" + , _port = 8080 + , _name = "custom" + } `shouldBe` WarpRuntimePlan + { runtimeBindHost = "127.0.0.1" + , runtimePort = 8080 + , runtimeServerName = "custom" + , runtimeNoParsePath = True + } - it "uses dynamic SNI credentials and disables reusable TLS sessions" $ do - let settings = buildTlsSettings $ \_ -> return $ TLS.Credentials [] - case tlsCredentials settings of - Just (TLS.Credentials credentials) -> credentials `shouldBe` [] - Nothing -> expectationFailure "expected explicit empty TLS credentials" - case tlsSessionManager settings of - Nothing -> return () - Just _ -> expectationFailure "expected disabled TLS session manager" - TLS.Credentials credentials <- TLS.onServerNameIndication (tlsServerHooks settings) Nothing - credentials `shouldBe` [] - describe "runner selection" $ do - it "selects the plain Warp runner when no certificates are configured" $ - selectRunnerPlan defaultConfig [] `shouldBe` PlainWarpRunner + it "uses dynamic SNI credentials and disables reusable TLS sessions" $ do + let settings = buildTlsSettings $ \_ -> return $ TLS.Credentials [] + case tlsCredentials settings of + Just (TLS.Credentials credentials) -> credentials `shouldBe` [] + Nothing -> expectationFailure "expected explicit empty TLS credentials" + case tlsSessionManager settings of + Nothing -> return () + Just _ -> expectationFailure "expected disabled TLS session manager" + TLS.Credentials credentials <- TLS.onServerNameIndication (tlsServerHooks settings) Nothing + credentials `shouldBe` [] + describe "runner selection" $ do + it "selects the plain Warp runner when no certificates are configured" $ + selectRunnerPlan defaultConfig [] `shouldBe` PlainWarpRunner - it "selects the TLS Warp runner when certificates are configured" $ - selectRunnerPlan defaultConfig [("example.com", ())] `shouldBe` TlsWarpRunner + it "selects the TLS Warp runner when certificates are configured" $ + selectRunnerPlan defaultConfig [("example.com", ())] `shouldBe` TlsWarpRunner #ifdef QUIC_ENABLED - it "selects concurrent QUIC and TLS when QUIC is configured with certificates" $ - selectRunnerPlan defaultConfig { _quic = Just 443 } [("example.com", ())] - `shouldBe` QuicAndTlsRunner 443 + it "selects concurrent QUIC and TLS when QUIC is configured with certificates" $ + selectRunnerPlan defaultConfig { _quic = Just 443 } [("example.com", ())] + `shouldBe` QuicAndTlsRunner 443 - it "does not select QUIC without configured certificates" $ - selectRunnerPlan defaultConfig { _quic = Just 443 } [] `shouldBe` PlainWarpRunner + it "does not select QUIC without configured certificates" $ + selectRunnerPlan defaultConfig { _quic = Just 443 } [] `shouldBe` PlainWarpRunner - it "builds safer QUIC defaults" $ do - quicUse0RTT `shouldBe` False - quicAddressPlan Nothing 8443 `shouldBe` [("0.0.0.0", 8443), ("::", 8443)] - quicAddressPlan (Just "127.0.0.1") 8443 `shouldBe` [("127.0.0.1", 8443)] - quicAltSvc 8443 `shouldBe` "h3=\":8443\"" + it "builds safer QUIC defaults" $ do + quicUse0RTT `shouldBe` False + quicAddressPlan Nothing 8443 `shouldBe` [("0.0.0.0", 8443), ("::", 8443)] + quicAddressPlan (Just "127.0.0.1") 8443 `shouldBe` [("127.0.0.1", 8443)] + quicAltSvc 8443 `shouldBe` "h3=\":8443\"" - it "builds QUIC TLS config without stale credentials" $ do - sessionManager <- SM.newSessionManager quicSessionManagerConfig - let onSNI host = - if host == Just "example.com" - then return $ TLS.Credentials [] - else fail $ "unexpected SNI host: " <> show host - config = buildQuicServerConfig Nothing onSNI sessionManager 8443 - SM.dbMaxSize quicSessionManagerConfig `shouldBe` 0 - case Q.scCredentials config of - TLS.Credentials credentials -> credentials `shouldBe` [] - TLS.Credentials credentials <- TLS.onServerNameIndication (Q.scTlsHooks config) (Just "example.com") - credentials `shouldBe` [] + it "builds QUIC TLS config without stale credentials" $ do + sessionManager <- SM.newSessionManager quicSessionManagerConfig + let onSNI host = + if host == Just "example.com" + then return $ TLS.Credentials [] + else fail $ "unexpected SNI host: " <> show host + config = buildQuicServerConfig Nothing onSNI sessionManager 8443 + SM.dbMaxSize quicSessionManagerConfig `shouldBe` 0 + case Q.scCredentials config of + TLS.Credentials credentials -> credentials `shouldBe` [] + TLS.Credentials credentials <- TLS.onServerNameIndication (Q.scTlsHooks config) (Just "example.com") + credentials `shouldBe` [] #endif #ifdef OS_UNIX - describe "privilege drop planning" $ do - it "uses the target user's primary group when no group is configured" $ do - let userEntry = ResolvedUser "alice" 1001 2001 - groups = - [ ResolvedGroup "primary" 2001 [] - , ResolvedGroup "extra" 2002 ["alice"] - , ResolvedGroup "other" 2003 ["bob"] - ] - planPrivilegeDrop (Just userEntry) Nothing groups - `shouldBe` PrivilegeDropPlan - { privilegeDropUserName = Just "alice" - , privilegeDropUserID = Just 1001 - , privilegeDropGroupName = Nothing - , privilegeDropGroupID = Just 2001 - , privilegeDropSupplementaryGroups = [2001, 2002] - } + describe "privilege drop planning" $ do + it "uses the target user's primary group when no group is configured" $ do + let userEntry = ResolvedUser "alice" 1001 2001 + groups = + [ ResolvedGroup "primary" 2001 [] + , ResolvedGroup "extra" 2002 ["alice"] + , ResolvedGroup "other" 2003 ["bob"] + ] + planPrivilegeDrop (Just userEntry) Nothing groups + `shouldBe` PrivilegeDropPlan + { privilegeDropUserName = Just "alice" + , privilegeDropUserID = Just 1001 + , privilegeDropGroupName = Nothing + , privilegeDropGroupID = Just 2001 + , privilegeDropSupplementaryGroups = [2001, 2002] + } - it "uses an explicit primary group for a target user" $ do - let userEntry = ResolvedUser "alice" 1001 2001 - groupEntry = ResolvedGroup "service" 3001 [] - groups = [ResolvedGroup "extra" 2002 ["alice"]] - planPrivilegeDrop (Just userEntry) (Just groupEntry) groups - `shouldBe` PrivilegeDropPlan - { privilegeDropUserName = Just "alice" - , privilegeDropUserID = Just 1001 - , privilegeDropGroupName = Just "service" - , privilegeDropGroupID = Just 3001 - , privilegeDropSupplementaryGroups = [3001, 2002] - } + it "uses an explicit primary group for a target user" $ do + let userEntry = ResolvedUser "alice" 1001 2001 + groupEntry = ResolvedGroup "service" 3001 [] + groups = [ResolvedGroup "extra" 2002 ["alice"]] + planPrivilegeDrop (Just userEntry) (Just groupEntry) groups + `shouldBe` PrivilegeDropPlan + { privilegeDropUserName = Just "alice" + , privilegeDropUserID = Just 1001 + , privilegeDropGroupName = Just "service" + , privilegeDropGroupID = Just 3001 + , privilegeDropSupplementaryGroups = [3001, 2002] + } - it "clears supplementary groups for group-only drops" $ do - let groupEntry = ResolvedGroup "service" 3001 ["alice"] - planPrivilegeDrop Nothing (Just groupEntry) [groupEntry] - `shouldBe` PrivilegeDropPlan - { privilegeDropUserName = Nothing - , privilegeDropUserID = Nothing - , privilegeDropGroupName = Just "service" - , privilegeDropGroupID = Just 3001 - , privilegeDropSupplementaryGroups = [] - } + it "clears supplementary groups for group-only drops" $ do + let groupEntry = ResolvedGroup "service" 3001 ["alice"] + planPrivilegeDrop Nothing (Just groupEntry) [groupEntry] + `shouldBe` PrivilegeDropPlan + { privilegeDropUserName = Nothing + , privilegeDropUserID = Nothing + , privilegeDropGroupName = Just "service" + , privilegeDropGroupID = Just 3001 + , privilegeDropSupplementaryGroups = [] + } #endif - describe "access log filtering" $ do - it "suppresses health-check access logs" $ - shouldSuppressAccessLog defaultRequest { rawPathInfo = "/.hprox/health" } `shouldBe` True + describe "access log filtering" $ do + it "suppresses health-check access logs" $ + shouldSuppressAccessLog defaultRequest { rawPathInfo = "/.hprox/health" } `shouldBe` True - it "keeps normal request access logs" $ - shouldSuppressAccessLog defaultRequest { rawPathInfo = "/" } `shouldBe` False + it "keeps normal request access logs" $ + shouldSuppressAccessLog defaultRequest { rawPathInfo = "/" } `shouldBe` False - describe "runtime exception filtering" $ do - it "suppresses all exception logs above DEBUG level" $ - runtimeExceptionToLog INFO displayedException `shouldSatisfy` isNothing + describe "runtime exception filtering" $ do + it "suppresses all exception logs above DEBUG level" $ + runtimeExceptionToLog INFO displayedException `shouldSatisfy` isNothing - it "keeps ordinary displayable exceptions at DEBUG level" $ - runtimeExceptionToLog DEBUG displayedException `shouldSatisfy` isJust + it "keeps ordinary displayable exceptions at DEBUG level" $ + runtimeExceptionToLog DEBUG displayedException `shouldSatisfy` isJust - it "unwraps HTTP/2 wrappers before selecting the exception to log" $ - fmap displayException (runtimeExceptionToLog DEBUG (toException (H2.BadThingHappen displayedException))) - `shouldBe` Just (displayException displayedException) + it "unwraps HTTP/2 wrappers before selecting the exception to log" $ + fmap displayException (runtimeExceptionToLog DEBUG (toException (H2.BadThingHappen displayedException))) + `shouldBe` Just (displayException displayedException) - it "suppresses EOF IO exceptions" $ - runtimeExceptionToLog DEBUG eofException `shouldSatisfy` isNothing + it "suppresses EOF IO exceptions" $ + runtimeExceptionToLog DEBUG eofException `shouldSatisfy` isNothing - it "suppresses HTTP/2 errors and recursively classified HTTP/2 wrappers" $ do - runtimeExceptionToLog DEBUG (toException H2.ConnectionIsClosed) `shouldSatisfy` isNothing - runtimeExceptionToLog DEBUG (toException (H2.BadThingHappen eofException)) `shouldSatisfy` isNothing + it "suppresses HTTP/2 errors and recursively classified HTTP/2 wrappers" $ do + runtimeExceptionToLog DEBUG (toException H2.ConnectionIsClosed) `shouldSatisfy` isNothing + runtimeExceptionToLog DEBUG (toException (H2.BadThingHappen eofException)) `shouldSatisfy` isNothing #ifdef QUIC_ENABLED - it "suppresses QUIC errors and recursively classified QUIC wrappers" $ do - runtimeExceptionToLog DEBUG (toException Q.ConnectionIsReset) `shouldSatisfy` isNothing - runtimeExceptionToLog DEBUG (toException (Q.BadThingHappen eofException)) `shouldSatisfy` isNothing + it "suppresses QUIC errors and recursively classified QUIC wrappers" $ do + runtimeExceptionToLog DEBUG (toException Q.ConnectionIsReset) `shouldSatisfy` isNothing + runtimeExceptionToLog DEBUG (toException (Q.BadThingHappen eofException)) `shouldSatisfy` isNothing #endif - it "suppresses Warp TLS and peer-close exceptions" $ do - runtimeExceptionToLog DEBUG (toException InsecureConnectionDenied) `shouldSatisfy` isNothing - runtimeExceptionToLog DEBUG (toException ConnectionClosedByPeer) `shouldSatisfy` isNothing + it "suppresses Warp TLS and peer-close exceptions" $ do + runtimeExceptionToLog DEBUG (toException InsecureConnectionDenied) `shouldSatisfy` isNothing + runtimeExceptionToLog DEBUG (toException ConnectionClosedByPeer) `shouldSatisfy` isNothing displayedException :: SomeException displayedException = toException $ userError "display me" diff --git a/test/Network/HProx/TLSSpec.hs b/test/Network/HProx/TLSSpec.hs --- a/test/Network/HProx/TLSSpec.hs +++ b/test/Network/HProx/TLSSpec.hs @@ -26,239 +26,237 @@ spec :: Spec spec = do - describe "SNI selection" $ do - it "matches exact SNI hostnames case-insensitively" $ do - lookupSNIHost (Just "EXAMPLE.com") [("example.com", "cert" :: String), ("other.example", "other")] - `shouldBe` Right "cert" - sniPatternMatches "EXAMPLE.com" "example.COM" `shouldBe` True - sniPatternMatches "Ä.example.com" "ä.example.com" `shouldBe` False - - it "matches wildcard SNI hostnames case-insensitively for one label only" $ do - sniPatternMatches "api.example.com" "*.example.com" `shouldBe` True - sniPatternMatches "API.example.com" "*.EXAMPLE.com" `shouldBe` True - sniPatternMatches "deep.api.example.com" "*.example.com" `shouldBe` False - sniPatternMatches "example.com" "*.example.com" `shouldBe` False - sniPatternMatches ".example.com" "*.example.com" `shouldBe` False - sniPatternMatches "badexample.com" "*.example.com" `shouldBe` False + describe "SNI selection" $ do + it "matches exact SNI hostnames case-insensitively" $ do + lookupSNIHost (Just "EXAMPLE.com") [("example.com", "cert" :: String), ("other.example", "other")] + `shouldBe` Right "cert" + sniPatternMatches "EXAMPLE.com" "example.COM" `shouldBe` True + sniPatternMatches "Ä.example.com" "ä.example.com" `shouldBe` False - it "returns the first matching configured SNI certificate" $ - lookupSNIHost (Just "api.example.com") - [ ("*.example.com", "wildcard" :: String) - , ("api.example.com", "exact") - ] `shouldBe` Right "wildcard" + it "matches wildcard SNI hostnames case-insensitively for one label only" $ do + sniPatternMatches "api.example.com" "*.example.com" `shouldBe` True + sniPatternMatches "API.example.com" "*.EXAMPLE.com" `shouldBe` True + sniPatternMatches "deep.api.example.com" "*.example.com" `shouldBe` False + sniPatternMatches "example.com" "*.example.com" `shouldBe` False + sniPatternMatches ".example.com" "*.example.com" `shouldBe` False + sniPatternMatches "badexample.com" "*.example.com" `shouldBe` False - it "rejects multi-label wildcard SNI matches during lookup" $ - lookupSNIHost (Just "deep.api.example.com") [("*.example.com", "wildcard" :: String)] - `shouldBe` Left "SNI: unknown hostname (\"deep.api.example.com\")" + it "returns the first matching configured SNI certificate" $ + lookupSNIHost (Just "api.example.com") + [ ("*.example.com", "wildcard" :: String) + , ("api.example.com", "exact") + ] `shouldBe` Right "wildcard" - it "rejects unknown and missing SNI hosts with current failure messages" $ do - lookupSNIHost (Just "unknown.example") [("example.com", "cert" :: String)] - `shouldBe` Left "SNI: unknown hostname (\"unknown.example\")" - lookupSNIHost Nothing [("example.com", "cert" :: String)] - `shouldBe` Left "SNI: unspecified" + it "rejects multi-label wildcard SNI matches during lookup" $ + lookupSNIHost (Just "deep.api.example.com") [("*.example.com", "wildcard" :: String)] + `shouldBe` Left "SNI: unknown hostname (\"deep.api.example.com\")" - describe "TLS credential loading" $ do - it "throws a contextual IO exception when certificate loading fails" $ do - certPath <- missingPath "hprox-missing-cert.pem" - keyPath <- missingPath "hprox-missing-key.pem" - result <- try (loadTlsCredentials [("example.com", CertFile certPath keyPath)]) :: IO (Either SomeException [(String, TLS.Credential)]) - case result of - Left ex -> do - fromException ex `shouldSatisfy` (isNothing :: Maybe ErrorCall -> Bool) - let message = displayException ex - message `shouldContain` "example.com" - message `shouldContain` certPath - message `shouldContain` keyPath - Right _ -> expectationFailure "expected TLS credential loading to fail" + it "rejects unknown and missing SNI hosts with current failure messages" $ do + lookupSNIHost (Just "unknown.example") [("example.com", "cert" :: String)] + `shouldBe` Left "SNI: unknown hostname (\"unknown.example\")" + lookupSNIHost Nothing [("example.com", "cert" :: String)] + `shouldBe` Left "SNI: unspecified" - it "rejects production credentials with an empty certificate chain" $ - loadTlsCredentialFromMemory "not a certificate" testPrivateKey - `shouldBe` Left "loaded TLS credential has an empty certificate chain" + describe "TLS credential loading" $ do + it "throws a contextual IO exception when certificate loading fails" $ do + certPath <- missingPath "hprox-missing-cert.pem" + keyPath <- missingPath "hprox-missing-key.pem" + result <- try (loadTlsCredentials [("example.com", CertFile certPath keyPath)]) :: IO (Either SomeException [(String, TLS.Credential)]) + case result of + Left ex -> do + fromException ex `shouldSatisfy` (isNothing :: Maybe ErrorCall -> Bool) + let message = displayException ex + message `shouldContain` "example.com" + message `shouldContain` certPath + message `shouldContain` keyPath + Right _ -> expectationFailure "expected TLS credential loading to fail" - it "keeps the old production credential when reload parses an empty certificate chain" $ - withTempCredential "hprox-valid" testCertificate testPrivateKey $ \certFile -> do - store <- loadTlsCredentialStore [("example.com", certFile)] - oldSnapshot <- readTlsCredentialStore store - writeCredentialFiles certFile "not a certificate" testPrivateKey - (logger, readLogs) <- captureLogger - reloadTlsCredentialStore logger store - readTlsCredentialStore store `shouldReturn` oldSnapshot - logs <- readLogs - let errorMessages = [message | (ERROR, message) <- logs] - length errorMessages `shouldBe` 1 - unlines errorMessages `shouldContain` "example.com" - unlines errorMessages `shouldContain` certfile certFile - unlines errorMessages `shouldContain` keyfile certFile - unlines errorMessages `shouldContain` "empty certificate chain" + it "rejects production credentials with an empty certificate chain" $ + loadTlsCredentialFromMemory "not a certificate" testPrivateKey + `shouldBe` Left "loaded TLS credential has an empty certificate chain" - describe "reloadable TLS credential store" $ do - it "looks up SNI credentials from the current store snapshot" $ - withTempCredential "hprox-store" "cert-a" "key-a" $ \certFile -> do - store <- newTlsCredentialStore testCredentialLoader [("example.com", certFile)] - lookupTlsCredentialStore (Just "example.com") store `shouldReturn` "cert-a:key-a" - writeCredentialFiles certFile "cert-b" "key-b" - (logger, _) <- captureLogger - reloadTlsCredentialStore logger store - lookupTlsCredentialStore (Just "example.com") store `shouldReturn` "cert-b:key-b" + it "keeps the old production credential when reload parses an empty certificate chain" $ + withTempCredential "hprox-valid" testCertificate testPrivateKey $ \certFile -> do + store <- loadTlsCredentialStore [("example.com", certFile)] + oldSnapshot <- readTlsCredentialStore store + writeCredentialFiles certFile "not a certificate" testPrivateKey + (logger, readLogs) <- captureLogger + reloadTlsCredentialStore logger store + readTlsCredentialStore store `shouldReturn` oldSnapshot + logs <- readLogs + let errorMessages = [message | (ERROR, message) <- logs] + length errorMessages `shouldBe` 1 + unlines errorMessages `shouldContain` "example.com" + unlines errorMessages `shouldContain` certfile certFile + unlines errorMessages `shouldContain` keyfile certFile + unlines errorMessages `shouldContain` "empty certificate chain" - it "selects the current first configured credential for missing SNI" $ - withTempCredential "hprox-first" "first-cert" "first-key" $ \firstCert -> - withTempCredential "hprox-second" "second-cert" "second-key" $ \secondCert -> do - store <- newTlsCredentialStore testCredentialLoader - [ ("first.example", firstCert) - , ("second.example", secondCert) - ] - lookupTlsCredentialStore Nothing store `shouldReturn` "first-cert:first-key" - writeCredentialFiles firstCert "new-first-cert" "new-first-key" - (logger, _) <- captureLogger - reloadTlsCredentialStore logger store - lookupTlsCredentialStore Nothing store `shouldReturn` "new-first-cert:new-first-key" + describe "reloadable TLS credential store" $ do + it "looks up SNI credentials from the current store snapshot" $ + withTempCredential "hprox-store" "cert-a" "key-a" $ \certFile -> do + store <- newTlsCredentialStore testCredentialLoader [("example.com", certFile)] + lookupTlsCredentialStore (Just "example.com") store `shouldReturn` "cert-a:key-a" + writeCredentialFiles certFile "cert-b" "key-b" + (logger, _) <- captureLogger + reloadTlsCredentialStore logger store + lookupTlsCredentialStore (Just "example.com") store `shouldReturn` "cert-b:key-b" - it "logs an install message only for changed credentials" $ - withTempCredential "hprox-first" "first-cert" "first-key" $ \firstCert -> - withTempCredential "hprox-second" "second-cert" "second-key" $ \secondCert -> do - store <- newTlsCredentialStore testCredentialLoader - [ ("first.example", firstCert) - , ("second.example", secondCert) - ] - writeCredentialFiles firstCert "new-first-cert" "new-first-key" - (logger, readLogs) <- captureLogger - reloadTlsCredentialStore logger store - readTlsCredentialStore store `shouldReturn` - [ ("first.example", "new-first-cert:new-first-key") - , ("second.example", "second-cert:second-key") - ] - logs <- readLogs - let installMessages = [message | (INFO, message) <- logs, "installed reloaded TLS credential" `isInfixOf` message] - length installMessages `shouldBe` 1 - unlines installMessages `shouldContain` "first.example" - unlines installMessages `shouldContain` certfile firstCert - unlines installMessages `shouldNotSatisfy` isInfixOf (certfile secondCert) + it "rejects missing and unknown SNI instead of revealing a configured credential" $ + withTempCredential "hprox-first" "first-cert" "first-key" $ \firstCert -> + withTempCredential "hprox-second" "second-cert" "second-key" $ \secondCert -> do + store <- newTlsCredentialStore testCredentialLoader + [ ("first.example", firstCert) + , ("second.example", secondCert) + ] + lookupTlsCredentialStore Nothing store + `shouldThrow` (== userError "SNI: unspecified") + lookupTlsCredentialStore (Just "unknown.example") store + `shouldThrow` (== userError "SNI: unknown hostname (\"unknown.example\")") - it "keeps a failed entry, updates successful entries, and logs failure context" $ - withTempCredential "hprox-first" "first-cert" "first-key" $ \firstCert -> - withTempCredential "hprox-second" "second-cert" "second-key" $ \secondCert -> do - store <- newTlsCredentialStore failingCredentialLoader - [ ("first.example", firstCert) - , ("second.example", secondCert) - ] - writeCredentialFiles firstCert "bad-cert" "first-key" - writeCredentialFiles secondCert "new-second-cert" "new-second-key" - (logger, readLogs) <- captureLogger - reloadTlsCredentialStore logger store - readTlsCredentialStore store `shouldReturn` - [ ("first.example", "first-cert:first-key") - , ("second.example", "new-second-cert:new-second-key") - ] - logs <- readLogs - let errorMessages = [message | (ERROR, message) <- logs] - length errorMessages `shouldBe` 1 - unlines errorMessages `shouldContain` "first.example" - unlines errorMessages `shouldContain` certfile firstCert - unlines errorMessages `shouldContain` keyfile firstCert - unlines errorMessages `shouldContain` "bad test credential" + it "logs an install message only for changed credentials" $ + withTempCredential "hprox-first" "first-cert" "first-key" $ \firstCert -> + withTempCredential "hprox-second" "second-cert" "second-key" $ \secondCert -> do + store <- newTlsCredentialStore testCredentialLoader + [ ("first.example", firstCert) + , ("second.example", secondCert) + ] + writeCredentialFiles firstCert "new-first-cert" "new-first-key" + (logger, readLogs) <- captureLogger + reloadTlsCredentialStore logger store + readTlsCredentialStore store `shouldReturn` + [ ("first.example", "new-first-cert:new-first-key") + , ("second.example", "second-cert:second-key") + ] + logs <- readLogs + let installMessages = [message | (INFO, message) <- logs, "installed reloaded TLS credential" `isInfixOf` message] + length installMessages `shouldBe` 1 + unlines installMessages `shouldContain` "first.example" + unlines installMessages `shouldContain` certfile firstCert + unlines installMessages `shouldNotSatisfy` isInfixOf (certfile secondCert) + it "keeps a failed entry, updates successful entries, and logs failure context" $ + withTempCredential "hprox-first" "first-cert" "first-key" $ \firstCert -> + withTempCredential "hprox-second" "second-cert" "second-key" $ \secondCert -> do + store <- newTlsCredentialStore failingCredentialLoader + [ ("first.example", firstCert) + , ("second.example", secondCert) + ] + writeCredentialFiles firstCert "bad-cert" "first-key" + writeCredentialFiles secondCert "new-second-cert" "new-second-key" + (logger, readLogs) <- captureLogger + reloadTlsCredentialStore logger store + readTlsCredentialStore store `shouldReturn` + [ ("first.example", "first-cert:first-key") + , ("second.example", "new-second-cert:new-second-key") + ] + logs <- readLogs + let errorMessages = [message | (ERROR, message) <- logs] + length errorMessages `shouldBe` 1 + unlines errorMessages `shouldContain` "first.example" + unlines errorMessages `shouldContain` certfile firstCert + unlines errorMessages `shouldContain` keyfile firstCert + unlines errorMessages `shouldContain` "bad test credential" missingPath :: String -> IO FilePath missingPath template = do - tmpDir <- getTemporaryDirectory - (path, handle) <- openTempFile tmpDir template - hClose handle - removeFile path - return path + tmpDir <- getTemporaryDirectory + (path, handle) <- openTempFile tmpDir template + hClose handle + removeFile path + return path type CapturedLogs = [(LogLevel, String)] captureLogger :: IO (Logger, IO CapturedLogs) captureLogger = do - ref <- newIORef [] - let logger level message = - modifyIORef' ref (++ [(level, BS8.unpack $ fromLogStr message)]) - return (logger, readIORef ref) + ref <- newIORef [] + let logger level message = + modifyIORef' ref (++ [(level, BS8.unpack $ fromLogStr message)]) + return (logger, readIORef ref) testCredentialLoader :: TlsCredentialLoader String testCredentialLoader certFile = do - certBytes <- BS.readFile $ certfile certFile - keyBytes <- BS.readFile $ keyfile certFile - return $ Right LoadedCredential - { loadedCredentialValue = credentialValue certBytes keyBytes - , loadedCredentialCertificateFingerprint = fingerprintBytes certBytes - , loadedCredentialKeyFingerprint = fingerprintBytes keyBytes - } + certBytes <- BS.readFile $ certfile certFile + keyBytes <- BS.readFile $ keyfile certFile + return $ Right LoadedCredential + { loadedCredentialValue = credentialValue certBytes keyBytes + , loadedCredentialCertificateFingerprint = fingerprintBytes certBytes + , loadedCredentialKeyFingerprint = fingerprintBytes keyBytes + } failingCredentialLoader :: TlsCredentialLoader String failingCredentialLoader certFile = do - certBytes <- BS.readFile $ certfile certFile - keyBytes <- BS.readFile $ keyfile certFile - if certBytes == "bad-cert" - then return $ Left "bad test credential" - else return $ Right LoadedCredential - { loadedCredentialValue = credentialValue certBytes keyBytes - , loadedCredentialCertificateFingerprint = fingerprintBytes certBytes - , loadedCredentialKeyFingerprint = fingerprintBytes keyBytes - } + certBytes <- BS.readFile $ certfile certFile + keyBytes <- BS.readFile $ keyfile certFile + if certBytes == "bad-cert" + then return $ Left "bad test credential" + else return $ Right LoadedCredential + { loadedCredentialValue = credentialValue certBytes keyBytes + , loadedCredentialCertificateFingerprint = fingerprintBytes certBytes + , loadedCredentialKeyFingerprint = fingerprintBytes keyBytes + } credentialValue :: BS.ByteString -> BS.ByteString -> String credentialValue certBytes keyBytes = - BS8.unpack certBytes <> ":" <> BS8.unpack keyBytes + BS8.unpack certBytes <> ":" <> BS8.unpack keyBytes fingerprintBytes :: BS.ByteString -> Hash.Digest Hash.SHA256 fingerprintBytes = Hash.hash withTempCredential :: String -> BS.ByteString -> BS.ByteString -> (CertFile -> IO a) -> IO a withTempCredential template certBytes keyBytes = - bracket acquire release + bracket acquire release where acquire = do - tmpDir <- getTemporaryDirectory - (certPath, certHandle) <- openTempFile tmpDir $ template <> "-cert.pem" - (keyPath, keyHandle) <- openTempFile tmpDir $ template <> "-key.pem" - hClose certHandle - hClose keyHandle - let certFile = CertFile certPath keyPath - writeCredentialFiles certFile certBytes keyBytes - return certFile + tmpDir <- getTemporaryDirectory + (certPath, certHandle) <- openTempFile tmpDir $ template <> "-cert.pem" + (keyPath, keyHandle) <- openTempFile tmpDir $ template <> "-key.pem" + hClose certHandle + hClose keyHandle + let certFile = CertFile certPath keyPath + writeCredentialFiles certFile certBytes keyBytes + return certFile release (CertFile certPath keyPath) = do - removeFile certPath - removeFile keyPath + removeFile certPath + removeFile keyPath writeCredentialFiles :: CertFile -> BS.ByteString -> BS.ByteString -> IO () writeCredentialFiles (CertFile certPath keyPath) certBytes keyBytes = do - BS.writeFile certPath certBytes - BS.writeFile keyPath keyBytes + BS.writeFile certPath certBytes + BS.writeFile keyPath keyBytes testPrivateKey :: BS.ByteString testPrivateKey = BS8.pack $ - "-----BEGIN PRIVATE KEY-----\n" <> - "MIICeAIBADANBgkqhkiG9w0BAQEFAASCAmIwggJeAgEAAoGBAOWBh4304R0FzpHZ\n" <> - "PltVBN0lZ3WRqF/ETDhtqR071G/d7lkikLu0QXP7pCaDK4rHcHSm3TmE1Flcyc94\n" <> - "wfFIVJinXEiJd+bp1Yk/ZWkWTYMEX5OuYzWBhciULt+ekMz8I2W+gtFUyu5rL9M9\n" <> - "DaNPwQijTxYaykBJ4uXzUjxm7NwhAgMBAAECgYB6ndeUak6TOPUCSzTbivLMTB2Y\n" <> - "XLe+YpvuUfhWXA7FraaYDLWS81084Cb1RINQ4/ka+cOb5XGmRMK1i+jiRiibWw38\n" <> - "R/j0xZhsHSaGSuFlP189O+eA00q34vw0cvKxl1OJGcRF8/lq4qrpgh63iAM+EAC/\n" <> - "9ncMbpkQrmfluuuOAQJBAP6TLeVAnKnj4i0MtuN1xhofZ3Kdr2Ds1cbHxpeT/yE1\n" <> - "Q8HZEIynoFVfTZe2fJs0V6YlLlv4lJhfIXy/EixrmvECQQDmymzKz5hJhxlWNLLy\n" <> - "3t92gh3o03u5ijM7c+HVLJZVI4Co2ai9f0aRifOWKRAbmth5zUVDcJG53jMaQeQQ\n" <> - "D3QxAkEAyR0AvwHCQjyza5+FxEBAllaE5PlJmarAX99nNkxG27c2pieTeWrbsVYu\n" <> - "+FHEMuCw9aKd8y54Rb+xttlDxC/mIQJBAMLuUrlyYhQokdPoKwVMDb6Q5CZVCfmK\n" <> - "qv8aP7LIOCmtFOyI+ycjKz2eISnBgSNvxEwMfuYZXFx7OvqAkNqn0uECQQC59Uk/\n" <> - "yEl0AkTKP2tcn55afpArQfPdZbIns6koiAMpoyxJPTsB2wL9b77Z8cNfgknFQVpP\n" <> - "vpX74UfeEF0AYB7t\n" <> - "-----END PRIVATE KEY-----\n" + "-----BEGIN PRIVATE KEY-----\n" <> + "MIICeAIBADANBgkqhkiG9w0BAQEFAASCAmIwggJeAgEAAoGBAOWBh4304R0FzpHZ\n" <> + "PltVBN0lZ3WRqF/ETDhtqR071G/d7lkikLu0QXP7pCaDK4rHcHSm3TmE1Flcyc94\n" <> + "wfFIVJinXEiJd+bp1Yk/ZWkWTYMEX5OuYzWBhciULt+ekMz8I2W+gtFUyu5rL9M9\n" <> + "DaNPwQijTxYaykBJ4uXzUjxm7NwhAgMBAAECgYB6ndeUak6TOPUCSzTbivLMTB2Y\n" <> + "XLe+YpvuUfhWXA7FraaYDLWS81084Cb1RINQ4/ka+cOb5XGmRMK1i+jiRiibWw38\n" <> + "R/j0xZhsHSaGSuFlP189O+eA00q34vw0cvKxl1OJGcRF8/lq4qrpgh63iAM+EAC/\n" <> + "9ncMbpkQrmfluuuOAQJBAP6TLeVAnKnj4i0MtuN1xhofZ3Kdr2Ds1cbHxpeT/yE1\n" <> + "Q8HZEIynoFVfTZe2fJs0V6YlLlv4lJhfIXy/EixrmvECQQDmymzKz5hJhxlWNLLy\n" <> + "3t92gh3o03u5ijM7c+HVLJZVI4Co2ai9f0aRifOWKRAbmth5zUVDcJG53jMaQeQQ\n" <> + "D3QxAkEAyR0AvwHCQjyza5+FxEBAllaE5PlJmarAX99nNkxG27c2pieTeWrbsVYu\n" <> + "+FHEMuCw9aKd8y54Rb+xttlDxC/mIQJBAMLuUrlyYhQokdPoKwVMDb6Q5CZVCfmK\n" <> + "qv8aP7LIOCmtFOyI+ycjKz2eISnBgSNvxEwMfuYZXFx7OvqAkNqn0uECQQC59Uk/\n" <> + "yEl0AkTKP2tcn55afpArQfPdZbIns6koiAMpoyxJPTsB2wL9b77Z8cNfgknFQVpP\n" <> + "vpX74UfeEF0AYB7t\n" <> + "-----END PRIVATE KEY-----\n" testCertificate :: BS.ByteString testCertificate = BS8.pack $ - "-----BEGIN CERTIFICATE-----\n" <> - "MIICCDCCAXGgAwIBAgIUdG9y2ED6kiMvkMveoyy1uxRoeIUwDQYJKoZIhvcNAQEL\n" <> - "BQAwFjEUMBIGA1UEAwwLZXhhbXBsZS5jb20wHhcNMjYwNTI2MTUzMzQyWhcNMjYw\n" <> - "NTI3MTUzMzQyWjAWMRQwEgYDVQQDDAtleGFtcGxlLmNvbTCBnzANBgkqhkiG9w0B\n" <> - "AQEFAAOBjQAwgYkCgYEA5YGHjfThHQXOkdk+W1UE3SVndZGoX8RMOG2pHTvUb93u\n" <> - "WSKQu7RBc/ukJoMrisdwdKbdOYTUWVzJz3jB8UhUmKdcSIl35unViT9laRZNgwRf\n" <> - "k65jNYGFyJQu356QzPwjZb6C0VTK7msv0z0No0/BCKNPFhrKQEni5fNSPGbs3CEC\n" <> - "AwEAAaNTMFEwHQYDVR0OBBYEFIVxo9w8xVcdjoMDWXAc45756MAsMB8GA1UdIwQY\n" <> - "MBaAFIVxo9w8xVcdjoMDWXAc45756MAsMA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZI\n" <> - "hvcNAQELBQADgYEApCff6vbA5sIRVjRuxSj0Lw37RI6Qb8vaXDELxIrmXVL4b3al\n" <> - "fLV9eJ54Lmv5mws+mziC2Nohvh6nW343oRip85u8OfalLi5enxq7FnWoXeOPVUmr\n" <> - "8DnHkJjatk0TVsvV6JLHeJDzX/Pqw4G8JrBYbQVgOqsfWw6bk2vkrHzYOgA=\n" <> - "-----END CERTIFICATE-----\n" + "-----BEGIN CERTIFICATE-----\n" <> + "MIICCDCCAXGgAwIBAgIUdG9y2ED6kiMvkMveoyy1uxRoeIUwDQYJKoZIhvcNAQEL\n" <> + "BQAwFjEUMBIGA1UEAwwLZXhhbXBsZS5jb20wHhcNMjYwNTI2MTUzMzQyWhcNMjYw\n" <> + "NTI3MTUzMzQyWjAWMRQwEgYDVQQDDAtleGFtcGxlLmNvbTCBnzANBgkqhkiG9w0B\n" <> + "AQEFAAOBjQAwgYkCgYEA5YGHjfThHQXOkdk+W1UE3SVndZGoX8RMOG2pHTvUb93u\n" <> + "WSKQu7RBc/ukJoMrisdwdKbdOYTUWVzJz3jB8UhUmKdcSIl35unViT9laRZNgwRf\n" <> + "k65jNYGFyJQu356QzPwjZb6C0VTK7msv0z0No0/BCKNPFhrKQEni5fNSPGbs3CEC\n" <> + "AwEAAaNTMFEwHQYDVR0OBBYEFIVxo9w8xVcdjoMDWXAc45756MAsMB8GA1UdIwQY\n" <> + "MBaAFIVxo9w8xVcdjoMDWXAc45756MAsMA8GA1UdEwEB/wQFMAMBAf8wDQYJKoZI\n" <> + "hvcNAQELBQADgYEApCff6vbA5sIRVjRuxSj0Lw37RI6Qb8vaXDELxIrmXVL4b3al\n" <> + "fLV9eJ54Lmv5mws+mziC2Nohvh6nW343oRip85u8OfalLi5enxq7FnWoXeOPVUmr\n" <> + "8DnHkJjatk0TVsvV6JLHeJDzX/Pqw4G8JrBYbQVgOqsfWw6bk2vkrHzYOgA=\n" <> + "-----END CERTIFICATE-----\n" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -21,17 +21,17 @@ main :: IO () main = hspec $ do - describe "hprox test suite" $ - it "runs" $ - True `shouldBe` True - AuthSpec.spec - ConfigSpec.spec - DoHSpec.spec - PureSpec.spec - HeadersSpec.spec - MiddlewareSpec.spec - NaiveSpec.spec - RouteSpec.spec - ProxySpec.spec - TLSSpec.spec - RuntimeSpec.spec + describe "hprox test suite" $ + it "runs" $ + True `shouldBe` True + AuthSpec.spec + ConfigSpec.spec + DoHSpec.spec + PureSpec.spec + HeadersSpec.spec + MiddlewareSpec.spec + NaiveSpec.spec + RouteSpec.spec + ProxySpec.spec + TLSSpec.spec + RuntimeSpec.spec