HProx.hs

-- SPDX-License-Identifier: Apache-2.0
--
-- Copyright (C) 2026 Bin Jin. All Rights Reserved.
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-| Instead of running @hprox@ binary directly, you can use this library
    to run HProx in front of arbitrary WAI 'Application'.
-}

module Network.HProx
  ( CertFile(..)
  , Config(..)
  , LogLevel(..)
  , defaultConfig
  , getConfig
  , run
  ) where

import Control.Monad           (forM_, unless, when)
import Data.Version            (showVersion)
import Network.HTTP.Client.TLS (newTlsManager)
import Network.Wai             (Application)

import Network.HProx.Auth
import Network.HProx.Config
import Network.HProx.Log
import Network.HProx.Runtime
import Network.HProx.Unix
import Paths_hprox

-- | Run HProx in front of fallback 'Application', with specified 'Config'
run :: Application -- ^ fallback application
    -> Config      -- ^ configuration
    -> IO ()
run fallback conf@Config{..} =
    either (ioError . userError) runValidated (validateRuntimeConfig conf)
  where
    runValidated () =
        let runtimeConfig = buildRuntimeConfig conf
        in withLogger (logOutputType (runtimeConfigLogOutput runtimeConfig)) _loglevel $ \logger -> do
            logger INFO $ "hprox " <> toLogStr (showVersion version) <> " started"

            credentialStore <- loadTlsCredentialStore _ssl

            let isSSL = not (null _ssl)

            when isSSL $ do
                logger INFO $ "read " <> toLogStr (show $ length _ssl) <> " certificates"
                logger INFO $ "domains: " <> toLogStr (unwords $ map fst _ssl)
                installSighupHandler $ reloadTlsCredentialStore logger credentialStore

            let beforeMainLoop =
#ifdef OS_UNIX
                    Just doBeforeMainLoop
#else
                    Nothing
#endif
                settings = buildWarpSettings conf logger beforeMainLoop

#ifdef OS_UNIX
                doBeforeMainLoop = do
                    dropped <- dropRootPriviledge logger _user _group
#ifdef QUIC_ENABLED
                    case (dropped, _quic) of
                        (True, Just qport) | qport < 1024 ->
                            logger ERROR $ "dropping root priviledge will likely break QUIC connection over UDP port " <> toLogStr (show qport)
                        (True, _) -> logger INFO "root priviledge dropped"
                        _         -> return ()
#else
                    when dropped $ logger INFO "root priviledge dropped"
#endif
#endif

            pauth <- loadProxyAuth logger _auth

            manager <- newTlsManager

            let pset = buildProxySettings runtimeConfig conf logger pauth isSSL
                revSorted = runtimeConfigReverseRouteTuples runtimeConfig
                proxy = buildProxyApplication isSSL pset manager fallback

            forM_ _ws $ \ws -> logger INFO $ "websocket redirect: " <> toLogStr ws
            unless (null revSorted) $ logger INFO $ "reverse proxy: " <> toLogStr (show revSorted)
            forM_ _doh $ \doh -> logger INFO $ "DNS-over-HTTPS redirect: " <> toLogStr doh

            runProxyServer conf logger settings credentialStore proxy