-- SPDX-License-Identifier: Apache-2.0

-- Copyright (C) 2023 Bin Jin. All Rights Reserved.
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns        #-}

{-| 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 Data.ByteString.Char8       qualified as BS8
import Data.Default.Class          (def)
import Data.HashMap.Strict         qualified as HM
import Data.List                   (elemIndex, elemIndices, find, isSuffixOf, sortOn, (\\))
import Data.List.NonEmpty          (NonEmpty(..))
import Data.Ord                    (Down(..))
import Data.String                 (fromString)
import Data.Version                (showVersion)
import Network.HTTP.Client.TLS     (newTlsManager)
import Network.HTTP.Types          qualified as HT
import Network.TLS                 qualified as TLS
import Network.TLS.Extra.Cipher    qualified as TLS
import Network.TLS.SessionManager  qualified as SM
import Network.Wai                 (Application, rawPathInfo)
import Network.Wai.Handler.Warp
    (InvalidRequest(..), defaultSettings, defaultShouldDisplayException, runSettings, setHost,
    setLogger, setNoParsePath, setOnException, setPort, setServerName)
import Network.Wai.Handler.WarpTLS
    (OnInsecure(..), WarpTLSException, defaultTlsSettings, onInsecure, runTLS, tlsAllowedVersions,
    tlsCiphers, tlsCredentials, tlsServerHooks, tlsSessionManager)

import Control.Exception    (Exception(..))
import GHC.IO.Exception     (IOErrorType(..))
import Network.HTTP2.Client qualified as H2
import System.IO.Error      (ioeGetErrorType)

#ifdef QUIC_ENABLED
import Control.Concurrent.Async     (mapConcurrently_)
import Network.QUIC                 qualified as Q
import Network.QUIC.Internal        qualified as Q
import Network.Wai.Handler.Warp     (setAltSvc)
import Network.Wai.Handler.WarpQUIC (runQUIC)
#endif

#ifdef OS_UNIX
import Control.Exception        (SomeException, catch)
import Network.Wai.Handler.Warp (setBeforeMainLoop)
import System.Exit
import System.Posix.Process     (exitImmediately)
import System.Posix.User

#ifdef DROP_ALL_CAPS_EXCEPT_BIND
import Foreign.C.Types      (CInt(..))
import System.Directory     (listDirectory)
import System.Posix.Signals (sigUSR1)
import Text.Read            (readMaybe)
#endif
#endif

import Control.Monad
import Data.Maybe
import Options.Applicative

import Network.HProx.DoH
import Network.HProx.Impl
import Network.HProx.Log
import Network.HProx.Util
import Paths_hprox

-- | Configuration of HProx, see @hprox --help@ for details
data Config = Config
  { Config -> Maybe String
_bind     :: !(Maybe String)
  , Config -> Int
_port     :: !Int
  , Config -> [(String, CertFile)]
_ssl      :: ![(String, CertFile)]
  , Config -> Maybe String
_auth     :: !(Maybe FilePath)
  , Config -> Maybe ByteString
_ws       :: !(Maybe BS8.ByteString)
  , Config -> [(Maybe ByteString, ByteString, ByteString)]
_rev      :: ![(Maybe BS8.ByteString, BS8.ByteString, BS8.ByteString)]
  , Config -> Maybe String
_doh      :: !(Maybe String)
  , Config -> Bool
_hide     :: !Bool
  , Config -> Bool
_naive    :: !Bool
  , Config -> ByteString
_name     :: !BS8.ByteString
  , Config -> Maybe ByteString
_acme     :: !(Maybe BS8.ByteString)
  , Config -> String
_log      :: !String
  , Config -> LogLevel
_loglevel :: !LogLevel
#ifdef OS_UNIX
  , Config -> Maybe String
_user     :: !(Maybe String)
  , Config -> Maybe String
_group    :: !(Maybe String)
#endif
#ifdef QUIC_ENABLED
  , _quic     :: !(Maybe Int)
#endif
  }

-- | Default value of 'Config', same as running @hprox@ without arguments
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = Maybe String
-> Int
-> [(String, CertFile)]
-> Maybe String
-> Maybe ByteString
-> [(Maybe ByteString, ByteString, ByteString)]
-> Maybe String
-> Bool
-> Bool
-> ByteString
-> Maybe ByteString
-> String
-> LogLevel
-> Maybe String
-> Maybe String
-> Config
Config Maybe String
forall a. Maybe a
Nothing Int
3000 [] Maybe String
forall a. Maybe a
Nothing Maybe ByteString
forall a. Maybe a
Nothing [] Maybe String
forall a. Maybe a
Nothing Bool
False Bool
False ByteString
"hprox" Maybe ByteString
forall a. Maybe a
Nothing String
"stdout" LogLevel
INFO
#ifdef OS_UNIX
  Maybe String
forall a. Maybe a
Nothing
  Maybe String
forall a. Maybe a
Nothing
#endif
#ifdef QUIC_ENABLED
    Nothing
#endif

-- | Certificate file pairs
data CertFile = CertFile
  { CertFile -> String
certfile :: !FilePath
  , CertFile -> String
keyfile  :: !FilePath
  }

readCert :: CertFile -> IO TLS.Credential
readCert :: CertFile -> IO Credential
readCert (CertFile String
c String
k) = (String -> Credential)
-> (Credential -> Credential)
-> Either String Credential
-> Credential
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Credential
forall a. HasCallStack => String -> a
error Credential -> Credential
forall a. a -> a
id (Either String Credential -> Credential)
-> IO (Either String Credential) -> IO Credential
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO (Either String Credential)
TLS.credentialLoadX509 String
c String
k

parser :: ParserInfo Config
parser :: ParserInfo Config
parser = Parser Config -> InfoMod Config -> ParserInfo Config
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser ((Config -> Config) -> Config -> Config)
forall a. Parser (a -> a)
helper Parser ((Config -> Config) -> Config -> Config)
-> Parser (Config -> Config) -> Parser (Config -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Config -> Config)
forall a. Parser (a -> a)
ver Parser (Config -> Config) -> Parser Config -> Parser Config
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Config
config) (InfoMod Config
forall a. InfoMod a
fullDesc InfoMod Config -> InfoMod Config -> InfoMod Config
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod Config
forall a. String -> InfoMod a
progDesc String
desc)
  where
    parseSSL :: String -> Either a (String, CertFile)
parseSSL String
s = case Char -> String -> NonEmpty String
forall a. Eq a => a -> [a] -> NonEmpty [a]
splitBy Char
':' String
s of
        String
host :| [String
cert, String
key] -> (String, CertFile) -> Either a (String, CertFile)
forall a b. b -> Either a b
Right (String
host, String -> String -> CertFile
CertFile String
cert String
key)
        NonEmpty String
_otherwise          -> a -> Either a (String, CertFile)
forall a b. a -> Either a b
Left a
"invalid format for ssl certificates"

    parseRev0 :: String -> Maybe (Maybe a, ByteString, ByteString)
parseRev0 s :: String
s@(Char
'/':String
_) = case Char -> String -> [Int]
forall a. Eq a => a -> [a] -> [Int]
elemIndices Char
'/' String
s of
        []      -> Maybe (Maybe a, ByteString, ByteString)
forall a. Maybe a
Nothing
        [Int]
indices -> let (String
prefix, String
remote) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt ([Int] -> Int
forall a. HasCallStack => [a] -> a
last [Int]
indices Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) String
s
                   in (Maybe a, ByteString, ByteString)
-> Maybe (Maybe a, ByteString, ByteString)
forall a. a -> Maybe a
Just (Maybe a
forall a. Maybe a
Nothing, String -> ByteString
BS8.pack String
prefix, String -> ByteString
BS8.pack String
remote)
    parseRev0 String
remote = (Maybe a, ByteString, ByteString)
-> Maybe (Maybe a, ByteString, ByteString)
forall a. a -> Maybe a
Just (Maybe a
forall a. Maybe a
Nothing, ByteString
"/", String -> ByteString
BS8.pack String
remote)

    parseRev :: String -> Maybe (Maybe ByteString, ByteString, ByteString)
parseRev (Char
'/':Char
'/':String
s) = case Char -> String -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Char
'/' String
s of
        Maybe Int
Nothing  -> Maybe (Maybe ByteString, ByteString, ByteString)
forall a. Maybe a
Nothing
        Just Int
ind -> let (String
domain, String
other) = Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
ind String
s
                    in do (Maybe Any
_, ByteString
prefix, ByteString
remote) <- String -> Maybe (Maybe Any, ByteString, ByteString)
forall {a}. String -> Maybe (Maybe a, ByteString, ByteString)
parseRev0 String
other
                          (Maybe ByteString, ByteString, ByteString)
-> Maybe (Maybe ByteString, ByteString, ByteString)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (String -> ByteString
BS8.pack String
domain), ByteString
prefix, ByteString
remote)

    parseRev String
s = String -> Maybe (Maybe ByteString, ByteString, ByteString)
forall {a}. String -> Maybe (Maybe a, ByteString, ByteString)
parseRev0 String
s

    desc :: String
desc = String
"a lightweight HTTP proxy server, and more"
    ver :: Parser (a -> a)
ver = String -> Mod OptionFields (a -> a) -> Parser (a -> a)
forall a. String -> Mod OptionFields (a -> a) -> Parser (a -> a)
infoOption (Version -> String
showVersion Version
version) (String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"version" Mod OptionFields (a -> a)
-> Mod OptionFields (a -> a) -> Mod OptionFields (a -> a)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (a -> a)
forall (f :: * -> *) a. String -> Mod f a
help String
"Display the version information")

    config :: Parser Config
config = Maybe String
-> Int
-> [(String, CertFile)]
-> Maybe String
-> Maybe ByteString
-> [(Maybe ByteString, ByteString, ByteString)]
-> Maybe String
-> Bool
-> Bool
-> ByteString
-> Maybe ByteString
-> String
-> LogLevel
-> Maybe String
-> Maybe String
-> Config
Config (Maybe String
 -> Int
 -> [(String, CertFile)]
 -> Maybe String
 -> Maybe ByteString
 -> [(Maybe ByteString, ByteString, ByteString)]
 -> Maybe String
 -> Bool
 -> Bool
 -> ByteString
 -> Maybe ByteString
 -> String
 -> LogLevel
 -> Maybe String
 -> Maybe String
 -> Config)
-> Parser (Maybe String)
-> Parser
     (Int
      -> [(String, CertFile)]
      -> Maybe String
      -> Maybe ByteString
      -> [(Maybe ByteString, ByteString, ByteString)]
      -> Maybe String
      -> Bool
      -> Bool
      -> ByteString
      -> Maybe ByteString
      -> String
      -> LogLevel
      -> Maybe String
      -> Maybe String
      -> Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe String)
bind
                    Parser
  (Int
   -> [(String, CertFile)]
   -> Maybe String
   -> Maybe ByteString
   -> [(Maybe ByteString, ByteString, ByteString)]
   -> Maybe String
   -> Bool
   -> Bool
   -> ByteString
   -> Maybe ByteString
   -> String
   -> LogLevel
   -> Maybe String
   -> Maybe String
   -> Config)
-> Parser Int
-> Parser
     ([(String, CertFile)]
      -> Maybe String
      -> Maybe ByteString
      -> [(Maybe ByteString, ByteString, ByteString)]
      -> Maybe String
      -> Bool
      -> Bool
      -> ByteString
      -> Maybe ByteString
      -> String
      -> LogLevel
      -> Maybe String
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int
port
                    Parser
  ([(String, CertFile)]
   -> Maybe String
   -> Maybe ByteString
   -> [(Maybe ByteString, ByteString, ByteString)]
   -> Maybe String
   -> Bool
   -> Bool
   -> ByteString
   -> Maybe ByteString
   -> String
   -> LogLevel
   -> Maybe String
   -> Maybe String
   -> Config)
-> Parser [(String, CertFile)]
-> Parser
     (Maybe String
      -> Maybe ByteString
      -> [(Maybe ByteString, ByteString, ByteString)]
      -> Maybe String
      -> Bool
      -> Bool
      -> ByteString
      -> Maybe ByteString
      -> String
      -> LogLevel
      -> Maybe String
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [(String, CertFile)]
ssl
                    Parser
  (Maybe String
   -> Maybe ByteString
   -> [(Maybe ByteString, ByteString, ByteString)]
   -> Maybe String
   -> Bool
   -> Bool
   -> ByteString
   -> Maybe ByteString
   -> String
   -> LogLevel
   -> Maybe String
   -> Maybe String
   -> Config)
-> Parser (Maybe String)
-> Parser
     (Maybe ByteString
      -> [(Maybe ByteString, ByteString, ByteString)]
      -> Maybe String
      -> Bool
      -> Bool
      -> ByteString
      -> Maybe ByteString
      -> String
      -> LogLevel
      -> Maybe String
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe String)
auth
                    Parser
  (Maybe ByteString
   -> [(Maybe ByteString, ByteString, ByteString)]
   -> Maybe String
   -> Bool
   -> Bool
   -> ByteString
   -> Maybe ByteString
   -> String
   -> LogLevel
   -> Maybe String
   -> Maybe String
   -> Config)
-> Parser (Maybe ByteString)
-> Parser
     ([(Maybe ByteString, ByteString, ByteString)]
      -> Maybe String
      -> Bool
      -> Bool
      -> ByteString
      -> Maybe ByteString
      -> String
      -> LogLevel
      -> Maybe String
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe ByteString)
ws
                    Parser
  ([(Maybe ByteString, ByteString, ByteString)]
   -> Maybe String
   -> Bool
   -> Bool
   -> ByteString
   -> Maybe ByteString
   -> String
   -> LogLevel
   -> Maybe String
   -> Maybe String
   -> Config)
-> Parser [(Maybe ByteString, ByteString, ByteString)]
-> Parser
     (Maybe String
      -> Bool
      -> Bool
      -> ByteString
      -> Maybe ByteString
      -> String
      -> LogLevel
      -> Maybe String
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser [(Maybe ByteString, ByteString, ByteString)]
rev
                    Parser
  (Maybe String
   -> Bool
   -> Bool
   -> ByteString
   -> Maybe ByteString
   -> String
   -> LogLevel
   -> Maybe String
   -> Maybe String
   -> Config)
-> Parser (Maybe String)
-> Parser
     (Bool
      -> Bool
      -> ByteString
      -> Maybe ByteString
      -> String
      -> LogLevel
      -> Maybe String
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe String)
doh
                    Parser
  (Bool
   -> Bool
   -> ByteString
   -> Maybe ByteString
   -> String
   -> LogLevel
   -> Maybe String
   -> Maybe String
   -> Config)
-> Parser Bool
-> Parser
     (Bool
      -> ByteString
      -> Maybe ByteString
      -> String
      -> LogLevel
      -> Maybe String
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
hide
                    Parser
  (Bool
   -> ByteString
   -> Maybe ByteString
   -> String
   -> LogLevel
   -> Maybe String
   -> Maybe String
   -> Config)
-> Parser Bool
-> Parser
     (ByteString
      -> Maybe ByteString
      -> String
      -> LogLevel
      -> Maybe String
      -> Maybe String
      -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool
naive
                    Parser
  (ByteString
   -> Maybe ByteString
   -> String
   -> LogLevel
   -> Maybe String
   -> Maybe String
   -> Config)
-> Parser ByteString
-> Parser
     (Maybe ByteString
      -> String -> LogLevel -> Maybe String -> Maybe String -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString
name
                    Parser
  (Maybe ByteString
   -> String -> LogLevel -> Maybe String -> Maybe String -> Config)
-> Parser (Maybe ByteString)
-> Parser
     (String -> LogLevel -> Maybe String -> Maybe String -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe ByteString)
acme
                    Parser
  (String -> LogLevel -> Maybe String -> Maybe String -> Config)
-> Parser String
-> Parser (LogLevel -> Maybe String -> Maybe String -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String
logging
                    Parser (LogLevel -> Maybe String -> Maybe String -> Config)
-> Parser LogLevel
-> Parser (Maybe String -> Maybe String -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser LogLevel
loglevel
#ifdef OS_UNIX
                    Parser (Maybe String -> Maybe String -> Config)
-> Parser (Maybe String) -> Parser (Maybe String -> Config)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe String)
user
                    Parser (Maybe String -> Config)
-> Parser (Maybe String) -> Parser Config
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser (Maybe String)
group
#endif
#ifdef QUIC_ENABLED
                    <*> quic
#endif

    bind :: Parser (Maybe String)
bind = Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> Parser String -> Parser (Maybe String)
forall a b. (a -> b) -> a -> b
$ Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"bind"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'b'
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"bind_ip"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Specify the IP address to bind to (default: all interfaces)")

    port :: Parser Int
port = ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto
        ( String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"port"
       Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'p'
       Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"port"
       Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Int
3000
       Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields Int
forall a (f :: * -> *). Show a => Mod f a
showDefault
       Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
help String
"Specify the port number")

    ssl :: Parser [(String, CertFile)]
ssl = Parser (String, CertFile) -> Parser [(String, CertFile)]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser (String, CertFile) -> Parser [(String, CertFile)])
-> Parser (String, CertFile) -> Parser [(String, CertFile)]
forall a b. (a -> b) -> a -> b
$ ReadM (String, CertFile)
-> Mod OptionFields (String, CertFile) -> Parser (String, CertFile)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((String -> Either String (String, CertFile))
-> ReadM (String, CertFile)
forall a. (String -> Either String a) -> ReadM a
eitherReader String -> Either String (String, CertFile)
forall {a}. IsString a => String -> Either a (String, CertFile)
parseSSL)
        ( String -> Mod OptionFields (String, CertFile)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"tls"
       Mod OptionFields (String, CertFile)
-> Mod OptionFields (String, CertFile)
-> Mod OptionFields (String, CertFile)
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields (String, CertFile)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
's'
       Mod OptionFields (String, CertFile)
-> Mod OptionFields (String, CertFile)
-> Mod OptionFields (String, CertFile)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (String, CertFile)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"hostname:cerfile:keyfile"
       Mod OptionFields (String, CertFile)
-> Mod OptionFields (String, CertFile)
-> Mod OptionFields (String, CertFile)
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields (String, CertFile)
forall (f :: * -> *) a. String -> Mod f a
help String
"Enable TLS and specify a domain with its associated TLS certificate (can be specified multiple times for multiple domains)")

    auth :: Parser (Maybe String)
auth = Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> Parser String -> Parser (Maybe String)
forall a b. (a -> b) -> a -> b
$ Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"auth"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'a'
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"userpass.txt"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Specify the password file for proxy authentication. Plaintext passwords should be in the format 'user:pass' and will be automatically Argon2-hashed by hprox. Ensure that the password file with plaintext password is writable")

    ws :: Parser (Maybe ByteString)
ws = Parser ByteString -> Parser (Maybe ByteString)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ByteString -> Parser (Maybe ByteString))
-> Parser ByteString -> Parser (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Mod OptionFields ByteString -> Parser ByteString
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( String -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"ws"
       Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"remote-host:port"
       Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields ByteString
forall (f :: * -> *) a. String -> Mod f a
help String
"Specify the remote host to handle WebSocket requests (port 443 indicates an HTTPS remote server)")

    rev :: Parser [(Maybe ByteString, ByteString, ByteString)]
rev = Parser (Maybe ByteString, ByteString, ByteString)
-> Parser [(Maybe ByteString, ByteString, ByteString)]
forall a. Parser a -> Parser [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Parser (Maybe ByteString, ByteString, ByteString)
 -> Parser [(Maybe ByteString, ByteString, ByteString)])
-> Parser (Maybe ByteString, ByteString, ByteString)
-> Parser [(Maybe ByteString, ByteString, ByteString)]
forall a b. (a -> b) -> a -> b
$ ReadM (Maybe ByteString, ByteString, ByteString)
-> Mod OptionFields (Maybe ByteString, ByteString, ByteString)
-> Parser (Maybe ByteString, ByteString, ByteString)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((String -> Maybe (Maybe ByteString, ByteString, ByteString))
-> ReadM (Maybe ByteString, ByteString, ByteString)
forall a. (String -> Maybe a) -> ReadM a
maybeReader String -> Maybe (Maybe ByteString, ByteString, ByteString)
parseRev)
        ( String
-> Mod OptionFields (Maybe ByteString, ByteString, ByteString)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"rev"
       Mod OptionFields (Maybe ByteString, ByteString, ByteString)
-> Mod OptionFields (Maybe ByteString, ByteString, ByteString)
-> Mod OptionFields (Maybe ByteString, ByteString, ByteString)
forall a. Semigroup a => a -> a -> a
<> String
-> Mod OptionFields (Maybe ByteString, ByteString, ByteString)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"[//domain/][/prefix/]remote-host:port"
       Mod OptionFields (Maybe ByteString, ByteString, ByteString)
-> Mod OptionFields (Maybe ByteString, ByteString, ByteString)
-> Mod OptionFields (Maybe ByteString, ByteString, ByteString)
forall a. Semigroup a => a -> a -> a
<> String
-> Mod OptionFields (Maybe ByteString, ByteString, ByteString)
forall (f :: * -> *) a. String -> Mod f a
help String
"Specify the remote host for reverse proxy (port 443 indicates an HTTPS remote server). An optional '//domain/' will only process requests with the 'Host: domain' header, and an optional '/prefix/' can be specified as a prefix to be matched (and stripped in proxied request)")

    doh :: Parser (Maybe String)
doh = Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> Parser String -> Parser (Maybe String)
forall a b. (a -> b) -> a -> b
$ Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"doh"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"dns-server:port"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Enable DNS-over-HTTPS (DoH) support (port 53 will be used if not specified)")

    hide :: Parser Bool
hide = Mod FlagFields Bool -> Parser Bool
switch
        ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"hide"
       Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Never send 'Proxy Authentication Required' response. Note that this might break the use of HTTPS proxy in browsers")

    naive :: Parser Bool
naive = Mod FlagFields Bool -> Parser Bool
switch
        ( String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"naive"
       Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Add naiveproxy-compatible padding (requires TLS)")

    name :: Parser ByteString
name = Mod OptionFields ByteString -> Parser ByteString
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( String -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"name"
       Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"server-name"
       Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value ByteString
"hprox"
       Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields ByteString
forall a (f :: * -> *). Show a => Mod f a
showDefault
       Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields ByteString
forall (f :: * -> *) a. String -> Mod f a
help String
"Specify the server name for the 'Server' header")

    acme :: Parser (Maybe ByteString)
acme = Parser ByteString -> Parser (Maybe ByteString)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser ByteString -> Parser (Maybe ByteString))
-> Parser ByteString -> Parser (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Mod OptionFields ByteString -> Parser ByteString
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( String -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"acme"
       Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields ByteString
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"ACCOUNT_THUMBPRINT"
       Mod OptionFields ByteString
-> Mod OptionFields ByteString -> Mod OptionFields ByteString
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields ByteString
forall (f :: * -> *) a. String -> Mod f a
help String
"Set the thumbprint for stateless http-01 ACME challenge as specified by RFC8555")

    logging :: Parser String
logging = Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"log"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"<none|stdout|stderr|file>"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value String
"stdout"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields String
forall a (f :: * -> *). Show a => Mod f a
showDefault
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Specify the logging type")

    loglevel :: Parser LogLevel
loglevel = ReadM LogLevel -> Mod OptionFields LogLevel -> Parser LogLevel
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ((String -> Maybe LogLevel) -> ReadM LogLevel
forall a. (String -> Maybe a) -> ReadM a
maybeReader String -> Maybe LogLevel
logLevelReader)
        ( String -> Mod OptionFields LogLevel
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"loglevel"
       Mod OptionFields LogLevel
-> Mod OptionFields LogLevel -> Mod OptionFields LogLevel
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields LogLevel
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"<trace|debug|info|warn|error|none>"
       Mod OptionFields LogLevel
-> Mod OptionFields LogLevel -> Mod OptionFields LogLevel
forall a. Semigroup a => a -> a -> a
<> LogLevel -> Mod OptionFields LogLevel
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value LogLevel
INFO
       Mod OptionFields LogLevel
-> Mod OptionFields LogLevel -> Mod OptionFields LogLevel
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields LogLevel
forall (f :: * -> *) a. String -> Mod f a
help String
"Specify the logging level (default: info)")

#ifdef OS_UNIX
    user :: Parser (Maybe String)
user = Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> Parser String -> Parser (Maybe String)
forall a b. (a -> b) -> a -> b
$ Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"user"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'u'
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"nobody"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Drop root priviledge and setuid to the specified user (like nobody)")

    group :: Parser (Maybe String)
group = Parser String -> Parser (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> Parser (Maybe String))
-> Parser String -> Parser (Maybe String)
forall a b. (a -> b) -> a -> b
$ Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
strOption
        ( String -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"group"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields String
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'g'
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"nogroup"
       Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields String
forall (f :: * -> *) a. String -> Mod f a
help String
"Drop root priviledge and setgid to the specified group")
#endif

#ifdef QUIC_ENABLED
    quic = optional $ option auto
        ( long "quic"
       <> short 'q'
       <> metavar "port"
       <> help "Enable QUIC (HTTP/3) on UDP port")
#endif

getLoggerType :: String -> LogType' LogStr
getLoggerType :: String -> LogType' LogStr
getLoggerType String
"none"   = LogType' LogStr
LogNone
getLoggerType String
"stdout" = Int -> LogType' LogStr
LogStdout Int
4096
getLoggerType String
"stderr" = Int -> LogType' LogStr
LogStderr Int
4096
getLoggerType String
file     = String -> Int -> LogType' LogStr
LogFileNoRotate String
file Int
4096

#ifdef OS_UNIX
dropRootPriviledge :: Logger -> Maybe String -> Maybe String -> IO Bool
dropRootPriviledge :: Logger -> Maybe String -> Maybe String -> IO Bool
dropRootPriviledge Logger
_ Maybe String
Nothing Maybe String
Nothing = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
dropRootPriviledge Logger
logger Maybe String
user Maybe String
group = do
    UserID
currentUser <- IO UserID
getRealUserID
    GroupID
currentGroup <- IO GroupID
getRealGroupID
    if UserID
currentUser UserID -> UserID -> Bool
forall a. Eq a => a -> a -> Bool
/= UserID
0 Bool -> Bool -> Bool
|| GroupID
currentGroup GroupID -> GroupID -> Bool
forall a. Eq a => a -> a -> Bool
/= GroupID
0
      then do
        Logger
logger LogLevel
WARN (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"Unable to setuid/setgid without root priviledge" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<>
                      LogStr
", userID=" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (UserID -> String
forall a. Show a => a -> String
show UserID
currentUser) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<>
                      LogStr
", groupID=" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (GroupID -> String
forall a. Show a => a -> String
show GroupID
currentGroup)
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      else do
        let abort :: LogStr -> IO b
abort LogStr
msg = Logger
logger LogLevel
ERROR LogStr
msg IO () -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ExitCode -> IO b
forall a. ExitCode -> IO a
exitImmediately (Int -> ExitCode
ExitFailure Int
1)
        Maybe String -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
group ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
group' -> do
            Logger
logger LogLevel
INFO (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"setgid to " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr String
group'
            String -> IO GroupEntry
getGroupEntryForName String
group' IO GroupEntry -> (GroupEntry -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GroupID -> IO ()
setGroupID (GroupID -> IO ())
-> (GroupEntry -> GroupID) -> GroupEntry -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GroupEntry -> GroupID
groupID
            GroupID
changedGroup <- IO GroupID
getRealGroupID
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GroupID
changedGroup GroupID -> GroupID -> Bool
forall a. Eq a => a -> a -> Bool
== GroupID
currentGroup) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr -> IO ()
forall {b}. LogStr -> IO b
abort LogStr
"failed to setgid, aborting"
        Maybe String -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
user ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
user' -> do
            Logger
logger LogLevel
INFO (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"setuid to " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr String
user'
            String -> IO UserEntry
getUserEntryForName String
user' IO UserEntry -> (UserEntry -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= UserID -> IO ()
setUserID (UserID -> IO ()) -> (UserEntry -> UserID) -> UserEntry -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UserEntry -> UserID
userID
            UserID
changedUser <- IO UserID
getRealUserID
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UserID
changedUser UserID -> UserID -> Bool
forall a. Eq a => a -> a -> Bool
== UserID
currentUser) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr -> IO ()
forall {b}. LogStr -> IO b
abort LogStr
"failed to setuid, aborting"
        Logger
logger LogLevel
DEBUG LogStr
"testing setuid(0), verify that root priviledge can't be regranted"
        IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (UserID -> IO ()
setUserID UserID
0) ((SomeException -> IO ()) -> IO ())
-> (SomeException -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
_ :: SomeException) -> Logger
logger LogLevel
DEBUG LogStr
"setuid(0) failed as expected"
        UserID
changedUser <- IO UserID
getRealUserID
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UserID
changedUser UserID -> UserID -> Bool
forall a. Eq a => a -> a -> Bool
== UserID
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr -> IO ()
forall {b}. LogStr -> IO b
abort LogStr
"unable to drop root priviledge, aborting"
        Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

#ifdef DROP_ALL_CAPS_EXCEPT_BIND
foreign import ccall unsafe "send_signal"
  c_send_signal :: CInt -> CInt -> IO ()

-- Taken from mighttpd2, see https://kazu-yamamoto.hatenablog.jp/entry/2020/12/10/150731 for details
dropAllCapsExceptBind :: IO ()
dropAllCapsExceptBind = do
    tids <- mapMaybe readMaybe <$> listDirectory "/proc/self/task"
    forM_ tids $ \tid -> c_send_signal tid sigUSR1
#endif
#endif

-- | Read 'Config' from command line arguments
getConfig :: IO Config
getConfig :: IO Config
getConfig = ParserInfo Config -> IO Config
forall a. ParserInfo a -> IO a
execParser ParserInfo Config
parser

-- | Run HProx in front of fallback 'Application', with specified 'Config'
run :: Application -- ^ fallback application
    -> Config      -- ^ configuration
    -> IO ()
run :: Application -> Config -> IO ()
run Application
fallback Config{Bool
Int
String
[(String, CertFile)]
[(Maybe ByteString, ByteString, ByteString)]
Maybe String
Maybe ByteString
ByteString
LogLevel
_bind :: Config -> Maybe String
_port :: Config -> Int
_ssl :: Config -> [(String, CertFile)]
_auth :: Config -> Maybe String
_ws :: Config -> Maybe ByteString
_rev :: Config -> [(Maybe ByteString, ByteString, ByteString)]
_doh :: Config -> Maybe String
_hide :: Config -> Bool
_naive :: Config -> Bool
_name :: Config -> ByteString
_acme :: Config -> Maybe ByteString
_log :: Config -> String
_loglevel :: Config -> LogLevel
_user :: Config -> Maybe String
_group :: Config -> Maybe String
_bind :: Maybe String
_port :: Int
_ssl :: [(String, CertFile)]
_auth :: Maybe String
_ws :: Maybe ByteString
_rev :: [(Maybe ByteString, ByteString, ByteString)]
_doh :: Maybe String
_hide :: Bool
_naive :: Bool
_name :: ByteString
_acme :: Maybe ByteString
_log :: String
_loglevel :: LogLevel
_user :: Maybe String
_group :: Maybe String
..} = LogType' LogStr -> LogLevel -> (Logger -> IO ()) -> IO ()
withLogger (String -> LogType' LogStr
getLoggerType String
_log) LogLevel
_loglevel ((Logger -> IO ()) -> IO ()) -> (Logger -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Logger
logger -> do
    Logger
logger LogLevel
INFO (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"hprox " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Version -> String
showVersion Version
version) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" started"
    Logger
logger LogLevel
INFO (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"bind to TCP port " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"[::]" Maybe String
_bind) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
":" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Int -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr Int
_port

    let certfiles :: [(String, CertFile)]
certfiles = [(String, CertFile)]
_ssl

    [Credential]
certs <- ((String, CertFile) -> IO Credential)
-> [(String, CertFile)] -> IO [Credential]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (CertFile -> IO Credential
readCert(CertFile -> IO Credential)
-> ((String, CertFile) -> CertFile)
-> (String, CertFile)
-> IO Credential
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(String, CertFile) -> CertFile
forall a b. (a, b) -> b
snd) [(String, CertFile)]
certfiles
    SessionManager
smgr <- Config -> IO SessionManager
SM.newSessionManager Config
SM.defaultConfig

    let isSSL :: Bool
isSSL = Bool -> Bool
not ([(String, CertFile)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, CertFile)]
certfiles)
        allCerts :: [(String, Credential)]
allCerts = [String] -> [Credential] -> [(String, Credential)]
forall a b. [a] -> [b] -> [(a, b)]
zip (((String, CertFile) -> String) -> [(String, CertFile)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, CertFile) -> String
forall a b. (a, b) -> a
fst [(String, CertFile)]
certfiles) [Credential]
certs

    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isSSL (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Logger
logger LogLevel
INFO (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"read " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ [Credential] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Credential]
certs) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
" certificates"
        Logger
logger LogLevel
INFO (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"domains: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr ([String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((String, Credential) -> String)
-> [(String, Credential)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Credential) -> String
forall a b. (a, b) -> a
fst [(String, Credential)]
allCerts)

    let settings :: Settings
settings = HostPreference -> Settings -> Settings
setHost (String -> HostPreference
forall a. IsString a => String -> a
fromString (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"*6" Maybe String
_bind)) (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
                   Int -> Settings -> Settings
setPort Int
_port (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
                   (Request -> Status -> Maybe Integer -> IO ())
-> Settings -> Settings
setLogger Request -> Status -> Maybe Integer -> IO ()
forall {p}. Request -> Status -> p -> IO ()
warpLogger (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
                   (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings
setOnException Maybe Request -> SomeException -> IO ()
exceptionHandler (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
#ifdef OS_UNIX
                   IO () -> Settings -> Settings
setBeforeMainLoop IO ()
doBeforeMainLoop (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
#endif
                   Bool -> Settings -> Settings
setNoParsePath Bool
True (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
                   ByteString -> Settings -> Settings
setServerName ByteString
_name Settings
defaultSettings

#ifdef OS_UNIX
        doBeforeMainLoop :: IO ()
doBeforeMainLoop = do
            Bool
dropped <- Logger -> Maybe String -> Maybe String -> IO Bool
dropRootPriviledge Logger
logger Maybe String
_user Maybe String
_group
#if defined(DROP_ALL_CAPS_EXCEPT_BIND)
            when dropped $ do
                logger INFO "drop all capabilities except CAP_NET_BIND_SERVICE"
                dropAllCapsExceptBind
#elif defined(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)
                _ -> return ()
#else
            () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#endif
#endif

        exceptionHandler :: Maybe Request -> SomeException -> IO ()
exceptionHandler Maybe Request
req SomeException
ex
            | LogLevel
_loglevel LogLevel -> LogLevel -> Bool
forall a. Ord a => a -> a -> Bool
> LogLevel
DEBUG                                 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool -> Bool
not (SomeException -> Bool
defaultShouldDisplayException SomeException
ex)            = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Just (IOError -> IOErrorType
ioeGetErrorType -> IOErrorType
EOF) <- SomeException -> Maybe IOError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Just (H2.BadThingHappen SomeException
ex') <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex  = Maybe Request -> SomeException -> IO ()
exceptionHandler Maybe Request
req SomeException
ex'
            | Just (HTTP2Error
_ :: H2.HTTP2Error) <- SomeException -> Maybe HTTP2Error
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex     = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
#ifdef QUIC_ENABLED
            | Just (Q.BadThingHappen ex') <- fromException ex   = exceptionHandler req ex'
            | Just (_ :: Q.QUICException) <- fromException ex   = return ()
#endif
            | Just (WarpTLSException
_ :: WarpTLSException) <- SomeException -> Maybe WarpTLSException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex  = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Just InvalidRequest
ConnectionClosedByPeer <- SomeException -> Maybe InvalidRequest
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
ex   = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool
otherwise                                         =
                Logger
logger LogLevel
DEBUG (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"exception: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
ex) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<>
                    LogStr -> (Request -> LogStr) -> Maybe Request -> LogStr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe LogStr
"" (\Request
req' -> LogStr
" from: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Request -> LogStr
logRequest Request
req') Maybe Request
req

        warpLogger :: Request -> Status -> p -> IO ()
warpLogger Request
req Status
status p
_
            | Request -> ByteString
rawPathInfo Request
req ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"/.hprox/health" = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            | Bool
otherwise                           =
                Logger
logger LogLevel
TRACE (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"(" LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Int -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (Status -> Int
HT.statusCode Status
status) LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> LogStr
") " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> Request -> LogStr
logRequest Request
req

        -- https://www.ssllabs.com/ssltest
        -- https://github.com/haskell-tls/hs-tls/blob/master/core/Network/TLS/Extra/Cipher.hs
        weak_ciphers :: [Cipher]
weak_ciphers = [ Cipher
TLS.cipher_ECDHE_RSA_AES256CBC_SHA384
                       , Cipher
TLS.cipher_ECDHE_RSA_AES256CBC_SHA
                       , Cipher
TLS.cipher_AES256CCM_SHA256
                       , Cipher
TLS.cipher_AES256GCM_SHA384
                       , Cipher
TLS.cipher_AES256_SHA256
                       , Cipher
TLS.cipher_AES256_SHA1
                       , Cipher
TLS.cipher_ECDHE_ECDSA_AES256CBC_SHA384
                       , Cipher
TLS.cipher_ECDHE_ECDSA_AES256CBC_SHA
                       ]

        tlsset :: TLSSettings
tlsset = TLSSettings
defaultTlsSettings
            { tlsServerHooks     = def { TLS.onServerNameIndication = onSNI }
            , tlsCredentials     = Just (TLS.Credentials [head certs])
            , onInsecure         = AllowInsecure
            , tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]
            , tlsCiphers         = TLS.ciphersuite_strong \\ weak_ciphers
            , tlsSessionManager  = Just smgr
            }

        onSNI :: Maybe String -> m Credentials
onSNI Maybe String
Nothing     = String -> m Credentials
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"SNI: unspecified"
        onSNI (Just String
host) = String -> [(String, Credential)] -> m Credentials
forall {m :: * -> *}.
MonadFail m =>
String -> [(String, Credential)] -> m Credentials
lookupSNI String
host [(String, Credential)]
allCerts

        lookupSNI :: String -> [(String, Credential)] -> m Credentials
lookupSNI String
host [] = String -> m Credentials
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"SNI: unknown hostname (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
host String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")")
        lookupSNI String
host ((String
p, Credential
cert) : [(String, Credential)]
cs)
          | String -> String -> Bool
checkSNI String
host String
p = Credentials -> m Credentials
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Credential] -> Credentials
TLS.Credentials [Credential
cert])
          | Bool
otherwise       = String -> [(String, Credential)] -> m Credentials
lookupSNI String
host [(String, Credential)]
cs

        checkSNI :: String -> String -> Bool
checkSNI String
host String
pat = case String
pat of
            Char
'*' : Char
'.' : String
p -> (Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
p) String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` String
host
            String
p             -> String
host String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
p

#ifdef QUIC_ENABLED
        alpn _ = return . fromMaybe "" . find (== "h3")
        altsvc qport = BS8.concat ["h3=\":", BS8.pack $ show qport ,"\""]

        quicset qport = Q.defaultServerConfig
            { Q.scAddresses      = [(fromString (fromMaybe "0.0.0.0" _bind), fromIntegral qport)]
            , Q.scVersions       = [Q.Version1, Q.Version2]
            , Q.scCredentials    = TLS.Credentials [head certs]
            , Q.scCiphers        = Q.scCiphers Q.defaultServerConfig \\ weak_ciphers
            , Q.scALPN           = Just alpn
            , Q.scTlsHooks       = def { TLS.onServerNameIndication = onSNI }
            , Q.scUse0RTT        = True
            , Q.scSessionManager = smgr
            }

        runner | not isSSL           = runSettings settings
               | Just qport <- _quic = \app -> do
                    logger INFO $ "bind to UDP port " <> toLogStr (fromMaybe "0.0.0.0" _bind) <> ":" <> toLogStr qport
                    mapConcurrently_ ($ app)
                        [ runQUIC (quicset qport) settings
                        , runTLS tlsset (setAltSvc (altsvc qport) settings)
                        ]
               | otherwise           = runTLS tlsset settings
#else
        runner :: Application -> IO ()
runner | Bool
isSSL     = TLSSettings -> Settings -> Application -> IO ()
runTLS TLSSettings
tlsset Settings
settings
               | Bool
otherwise = Settings -> Application -> IO ()
runSettings Settings
settings
#endif

    Maybe (ByteString -> Bool)
pauth <- case Maybe String
_auth of
        Maybe String
Nothing -> Maybe (ByteString -> Bool) -> IO (Maybe (ByteString -> Bool))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString -> Bool)
forall a. Maybe a
Nothing
        Just String
f  -> do
            Logger
logger LogLevel
INFO (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"read username and passwords from " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr String
f
            [ByteString]
userList <- ByteString -> [ByteString]
BS8.lines (ByteString -> [ByteString]) -> IO ByteString -> IO [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BS8.readFile String
f
            let anyPlaintext :: Bool
anyPlaintext = (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ByteString
line -> [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Char -> ByteString -> [Int]
BS8.elemIndices Char
':' ByteString
line) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
2) [ByteString]
userList
                processUser :: ByteString -> IO (Maybe (ByteString, PasswordSalted))
processUser ByteString
userpass = case ByteString -> Maybe (ByteString, Password)
passwordReader ByteString
userpass of
                    Maybe (ByteString, Password)
Nothing           -> do
                        Logger
logger LogLevel
WARN (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"unable to parse line from password file: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr ByteString
userpass
                        Maybe (ByteString, PasswordSalted)
-> IO (Maybe (ByteString, PasswordSalted))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (ByteString, PasswordSalted)
forall a. Maybe a
Nothing
                    Just (ByteString
user, Password
pass) -> do
                        PasswordSalted
salted <- Password -> IO PasswordSalted
hashPasswordWithRandomSalt Password
pass
                        Logger
logger LogLevel
TRACE (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"parsed user (with salted password) from password file: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr (ByteString -> PasswordSalted -> ByteString
passwordWriter ByteString
user PasswordSalted
salted)
                        Maybe (ByteString, PasswordSalted)
-> IO (Maybe (ByteString, PasswordSalted))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ByteString, PasswordSalted)
 -> IO (Maybe (ByteString, PasswordSalted)))
-> Maybe (ByteString, PasswordSalted)
-> IO (Maybe (ByteString, PasswordSalted))
forall a b. (a -> b) -> a -> b
$ (ByteString, PasswordSalted) -> Maybe (ByteString, PasswordSalted)
forall a. a -> Maybe a
Just (ByteString
user, PasswordSalted
salted)
            HashMap ByteString PasswordSalted
passwordByUser <- [(ByteString, PasswordSalted)] -> HashMap ByteString PasswordSalted
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(ByteString, PasswordSalted)]
 -> HashMap ByteString PasswordSalted)
-> ([Maybe (ByteString, PasswordSalted)]
    -> [(ByteString, PasswordSalted)])
-> [Maybe (ByteString, PasswordSalted)]
-> HashMap ByteString PasswordSalted
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (ByteString, PasswordSalted)]
-> [(ByteString, PasswordSalted)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ByteString, PasswordSalted)]
 -> HashMap ByteString PasswordSalted)
-> IO [Maybe (ByteString, PasswordSalted)]
-> IO (HashMap ByteString PasswordSalted)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> IO (Maybe (ByteString, PasswordSalted)))
-> [ByteString] -> IO [Maybe (ByteString, PasswordSalted)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ByteString -> IO (Maybe (ByteString, PasswordSalted))
processUser [ByteString]
userList
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
anyPlaintext (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Logger
logger LogLevel
INFO (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"writing back to password file " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr String
f
                String -> ByteString -> IO ()
BS8.writeFile String
f ([ByteString] -> ByteString
BS8.unlines [ ByteString -> PasswordSalted -> ByteString
passwordWriter ByteString
u PasswordSalted
p | (ByteString
u, PasswordSalted
p) <- HashMap ByteString PasswordSalted -> [(ByteString, PasswordSalted)]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap ByteString PasswordSalted
passwordByUser])
            let verify :: ByteString -> Maybe Bool
verify ByteString
line = do
                    Int
idx <- Char -> ByteString -> Maybe Int
BS8.elemIndex Char
':' ByteString
line
                    let user :: ByteString
user = Int -> ByteString -> ByteString
BS8.take Int
idx ByteString
line
                        pass :: ByteString
pass = Int -> ByteString -> ByteString
BS8.drop (Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ByteString
line
                    PasswordSalted
targetPass <- ByteString
-> HashMap ByteString PasswordSalted -> Maybe PasswordSalted
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup ByteString
user HashMap ByteString PasswordSalted
passwordByUser
                    Bool -> Maybe Bool
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ PasswordSalted -> ByteString -> Bool
verifyPassword PasswordSalted
targetPass ByteString
pass
            Maybe (ByteString -> Bool) -> IO (Maybe (ByteString -> Bool))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ByteString -> Bool) -> IO (Maybe (ByteString -> Bool)))
-> Maybe (ByteString -> Bool) -> IO (Maybe (ByteString -> Bool))
forall a b. (a -> b) -> a -> b
$ (ByteString -> Bool) -> Maybe (ByteString -> Bool)
forall a. a -> Maybe a
Just (\ByteString
line -> ByteString -> Maybe Bool
verify ByteString
line Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)

    Manager
manager <- IO Manager
forall (m :: * -> *). MonadIO m => m Manager
newTlsManager

    let revSorted :: [(Maybe ByteString, ByteString, ByteString)]
revSorted = ((Maybe ByteString, ByteString, ByteString) -> Down (Bool, Int))
-> [(Maybe ByteString, ByteString, ByteString)]
-> [(Maybe ByteString, ByteString, ByteString)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(Maybe ByteString
a,ByteString
b,ByteString
_) -> (Bool, Int) -> Down (Bool, Int)
forall a. a -> Down a
Down (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust Maybe ByteString
a, ByteString -> Int
BS8.length ByteString
b)) [(Maybe ByteString, ByteString, ByteString)]
_rev
        pset :: ProxySettings
pset = Maybe (ByteString -> Bool)
-> Maybe ByteString
-> Maybe ByteString
-> [(Maybe ByteString, ByteString, ByteString)]
-> Bool
-> Bool
-> Maybe ByteString
-> Logger
-> ProxySettings
ProxySettings Maybe (ByteString -> Bool)
pauth (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
_name) Maybe ByteString
_ws [(Maybe ByteString, ByteString, ByteString)]
revSorted Bool
_hide (Bool
_naive Bool -> Bool -> Bool
&& Bool
isSSL) Maybe ByteString
_acme Logger
logger
        proxy :: Application
proxy = Middleware
healthCheckProvider Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$
                ProxySettings -> Middleware
acmeProvider ProxySettings
pset Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$
                (if Bool
isSSL then ProxySettings -> Middleware
forceSSL ProxySettings
pset else Middleware
forall a. a -> a
id) Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$
                ProxySettings -> Manager -> Middleware
httpProxy ProxySettings
pset Manager
manager Middleware -> Middleware
forall a b. (a -> b) -> a -> b
$
                ProxySettings -> Manager -> Middleware
reverseProxy ProxySettings
pset Manager
manager Application
fallback

    Maybe ByteString -> (ByteString -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe ByteString
_ws ((ByteString -> IO ()) -> IO ()) -> (ByteString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ByteString
ws -> Logger
logger LogLevel
INFO (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"websocket redirect: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> ByteString -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr ByteString
ws
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Maybe ByteString, ByteString, ByteString)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Maybe ByteString, ByteString, ByteString)]
revSorted) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger
logger LogLevel
INFO (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"reverse proxy: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr ([(Maybe ByteString, ByteString, ByteString)] -> String
forall a. Show a => a -> String
show [(Maybe ByteString, ByteString, ByteString)]
revSorted)
    Maybe String -> (String -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe String
_doh ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \String
doh -> Logger
logger LogLevel
INFO (LogStr -> IO ()) -> LogStr -> IO ()
forall a b. (a -> b) -> a -> b
$ LogStr
"DNS-over-HTTPS redirect: " LogStr -> LogStr -> LogStr
forall a. Semigroup a => a -> a -> a
<> String -> LogStr
forall msg. ToLogStr msg => msg -> LogStr
toLogStr String
doh

    case Maybe String
_doh of
        Maybe String
Nothing  -> Application -> IO ()
runner Application
proxy
        Just String
doh -> String -> (Resolver -> IO ()) -> IO ()
forall a. String -> (Resolver -> IO a) -> IO a
createResolver String
doh (\Resolver
resolver -> Application -> IO ()
runner (Resolver -> Middleware
dnsOverHTTPS Resolver
resolver Application
proxy))