hprox-0.7.2: test/Network/HProx/TLSSpec.hs
-- SPDX-License-Identifier: Apache-2.0
--
-- Copyright (C) 2026 Bin Jin. All Rights Reserved.
module Network.HProx.TLSSpec
( spec
) where
import Control.Exception
(ErrorCall, SomeException, bracket, displayException, fromException, try)
import Crypto.Hash qualified as Hash
import Data.ByteString qualified as BS
import Data.ByteString.Char8 qualified as BS8
import Data.IORef (modifyIORef', newIORef, readIORef)
import Data.List (isInfixOf)
import Data.Maybe (isNothing)
import Network.HProx.Config (CertFile(..))
import Network.HProx.Log (LogLevel(..), Logger)
import Network.HProx.Runtime
import Network.TLS qualified as TLS
import System.Directory (getTemporaryDirectory, removeFile)
import System.IO (hClose, openTempFile)
import System.Log.FastLogger (fromLogStr)
import Test.Hspec
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
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 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 "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"
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 production credentials with an empty certificate chain" $
loadTlsCredentialFromMemory "not a certificate" testPrivateKey
`shouldBe` Left "loaded TLS credential has an empty certificate chain"
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"
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 "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 "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
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)
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
}
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
}
credentialValue :: BS.ByteString -> BS.ByteString -> String
credentialValue certBytes 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
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
release (CertFile certPath keyPath) = do
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
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"
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"