hprox 0.7.1 → 0.7.2
raw patch · 17 files changed
+1234/−1233 lines, 17 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +10/−0
- hprox.cabal +2/−2
- src/Network/HProx/DoH.hs +5/−5
- src/Network/HProx/Impl.hs +7/−8
- src/Network/HProx/Runtime.hs +13/−18
- test/Network/HProx/AuthSpec.hs +57/−57
- test/Network/HProx/ConfigSpec.hs +122/−122
- test/Network/HProx/DoHSpec.hs +72/−72
- test/Network/HProx/HeadersSpec.hs +18/−18
- test/Network/HProx/MiddlewareSpec.hs +104/−104
- test/Network/HProx/NaiveSpec.hs +23/−23
- test/Network/HProx/ProxySpec.hs +325/−326
- test/Network/HProx/PureSpec.hs +48/−48
- test/Network/HProx/RouteSpec.hs +83/−83
- test/Network/HProx/RuntimeSpec.hs +144/−144
- test/Network/HProx/TLSSpec.hs +187/−189
- test/Spec.hs +14/−14
CHANGELOG.md view
@@ -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
hprox.cabal view
@@ -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 <https://github.com/bjin/hprox#readme> category: Web
src/Network/HProx/DoH.hs view
@@ -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"
src/Network/HProx/Impl.hs view
@@ -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 = "<invalid>"@@ -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
src/Network/HProx/Runtime.hs view
@@ -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"
test/Network/HProx/AuthSpec.hs view
@@ -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
test/Network/HProx/ConfigSpec.hs view
@@ -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- ]+ ]
test/Network/HProx/DoHSpec.hs view
@@ -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
test/Network/HProx/HeadersSpec.hs view
@@ -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
test/Network/HProx/MiddlewareSpec.hs view
@@ -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 ()+ }
test/Network/HProx/NaiveSpec.hs view
@@ -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
test/Network/HProx/ProxySpec.hs view
@@ -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:<redacted>"- 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:<redacted>"+ 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 ()+ }
test/Network/HProx/PureSpec.hs view
@@ -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` [""]
test/Network/HProx/RouteSpec.hs view
@@ -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")]
test/Network/HProx/RuntimeSpec.hs view
@@ -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"
test/Network/HProx/TLSSpec.hs view
@@ -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"
test/Spec.hs view
@@ -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