RuntimeSpec.hs

-- SPDX-License-Identifier: Apache-2.0
--
-- Copyright (C) 2026 Bin Jin. All Rights Reserved.

{-# LANGUAGE CPP #-}

module Network.HProx.RuntimeSpec
  ( spec
  ) where

import Control.Exception           (SomeException, displayException, toException)
import Data.Maybe                  (isJust, isNothing)
import GHC.IO.Exception            (IOErrorType(..))
import Network.HTTP2.Client        qualified as H2
import Network.TLS                 qualified as TLS
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Handler.WarpTLS
import System.IO.Error             (mkIOError)

#ifdef QUIC_ENABLED
import Network.HProx.Quic
import Network.QUIC.Internal      qualified as Q
import Network.TLS.SessionManager qualified as SM
#endif
#ifdef OS_UNIX
import Network.HProx.Unix
#endif

import Network.HProx.Config
import Network.HProx.Log
import Network.HProx.Route
import Network.HProx.Runtime

import Test.Hspec

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 "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)"
#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
        }

    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 "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 "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 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]
          }

    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 = []
          }
#endif

  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

  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 "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 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
#endif

    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"

eofException :: SomeException
eofException = toException $ mkIOError EOF "eof" Nothing Nothing