hprox 0.6.1 → 0.6.2

raw patch · 9 files changed

+267/−136 lines, 9 filesdep +directorydep ~basedep ~bytestringdep ~http-typesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory

Dependency ranges changed: base, bytestring, http-types, wai

API changes (from Hackage documentation)

Files

• Changelog.md +6/−0
• cbits/setcap.c +60/−0
• hprox.cabal +11/−38
• src/Network/HProx.hs +132/−45
• src/Network/HProx/DoH.hs +2/−2
• src/Network/HProx/Impl.hs +34/−30
• src/Network/HProx/Log.hs +4/−4
• src/Network/HProx/Naive.hs +3/−4
• src/Network/HProx/Util.hs +15/−13

@@ -1,3 +1,9 @@+## 0.6.2++- fixes to improve ssltest result+- unix: support setuid after binding port+- remove graceful close+ ## 0.6.1  - multiple certificates and SNI support for HTTP/3

@@ -0,0 +1,60 @@+// SPDX-License-Identifier: BSD3+//+// Copyright (C) 2020 Kazu Yamamoto. All Rights Reserved.+//+// File taken from https://github.com/kazu-yamamoto/mighttpd2+// See https://kazu-yamamoto.hatenablog.jp/entry/2020/12/10/150731 for details+//+#if defined(__linux__)+#include <linux/securebits.h>+#include <signal.h>+#include <stdio.h>+#include <string.h>+#include <sys/capability.h>+#include <sys/prctl.h>+#include <sys/syscall.h>+#include <sys/types.h>+#include <unistd.h>++#include "Rts.h"++void set_capabilities (uint32_t cap) {+  cap_user_header_t header = malloc(sizeof(*header));+  header->version = _LINUX_CAPABILITY_VERSION_3;+  header->pid = 0;++  cap_user_data_t data = malloc(sizeof(*data));+  data->effective   = cap;+  data->permitted   = cap;+  data->inheritable = 0;++  capset(header,data);++  free(header);+  free(data);+}++void handler(int signum) {+  uint32_t cap = 1 << CAP_NET_BIND_SERVICE;+  set_capabilities (cap);+}++void FlagDefaultsHook () {+  if (geteuid() == 0) {+    prctl(PR_SET_SECUREBITS, SECBIT_KEEP_CAPS, 0L, 0L, 0L);++    struct sigaction sa;+    memset(&sa, 0, sizeof(sa));+    sa.sa_handler = handler;+    sa.sa_flags = SA_RESTART;+    sigaction(SIGUSR1, &sa, NULL);+  }+}++void send_signal (int tid, int sig) {+  int tgid = getpid();+  syscall(SYS_tgkill, tgid, tid, sig);+}+#else+void send_signal (int tid, int sig) {}+#endif

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           hprox-version:        0.6.1+version:        0.6.2 synopsis:       a lightweight HTTP proxy server, and more description:    Please see the README on GitHub at <https://github.com/bjin/hprox#readme> category:       Web@@ -87,6 +87,12 @@         http3 >=0.0.3       , quic >=0.1.15       , warp-quic+    if os(linux)+      cpp-options: -DDROP_ALL_CAPS_EXCEPT_BIND+      c-sources:+          cbits/setcap.c+      build-depends:+          directory >=1.2.5.0   if !os(windows)     cpp-options: -DOS_UNIX     build-depends:@@ -104,44 +110,11 @@       RecordWildCards   ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N   build-depends:-      async >=2.2-    , base >=4.12 && <5-    , base64-bytestring >=1.1-    , binary >=0.8-    , bytestring >=0.10-    , case-insensitive >=1.2-    , conduit >=1.3-    , conduit-extra >=1.3-    , crypton-    , data-default-class-    , dns >=4.0-    , fast-logger >=3.0+      base+    , bytestring     , hprox-    , http-client >=0.5-    , http-client-tls >=0.3.4-    , http-reverse-proxy >=0.6.0.2-    , http-types >=0.12-    , http2 >=4.0-    , optparse-applicative >=0.14-    , random >=1.2.1-    , text-    , tls >=1.5-    , tls-session-manager >=0.0.4-    , unordered-containers-    , wai >=3.2.2-    , wai-extra >=3.0-    , warp >=3.2.8-    , warp-tls >=3.2.12+    , http-types+    , wai   default-language: Haskell2010-  if flag(quic)-    cpp-options: -DQUIC_ENABLED-    build-depends:-        http3 >=0.0.3-      , quic >=0.1.15-      , warp-quic-  if !os(windows)-    cpp-options: -DOS_UNIX-    build-depends:-        unix   if flag(static)     ghc-options: -optl-static

@@ -10,9 +10,9 @@ -}  module Network.HProx-  ( CertFile (..)-  , Config (..)-  , LogLevel (..)+  ( CertFile(..)+  , Config(..)+  , LogLevel(..)   , defaultConfig   , getConfig   , run@@ -21,9 +21,9 @@ 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.Ord                    (Down (..))+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)@@ -33,16 +33,14 @@ 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)+    (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)+    (OnInsecure(..), WarpTLSException, defaultTlsSettings, onInsecure, runTLS, tlsAllowedVersions,+    tlsCiphers, tlsCredentials, tlsServerHooks, tlsSessionManager) -import Control.Exception    (Exception (..))-import GHC.IO.Exception     (IOErrorType (..))+import Control.Exception    (Exception(..))+import GHC.IO.Exception     (IOErrorType(..)) import Network.HTTP2.Client qualified as H2 import System.IO.Error      (ioeGetErrorType) @@ -55,10 +53,19 @@ #endif  #ifdef OS_UNIX-import Network.Wai.Handler.Warp-    (setGracefulShutdownTimeout, setInstallShutdownHandler)-import System.Posix.Signals+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@@ -72,35 +79,43 @@  -- | Configuration of HProx, see @hprox --help@ for details data Config = Config-  { _bind     :: Maybe String-  , _port     :: Int-  , _ssl      :: [(String, CertFile)]-  , _auth     :: Maybe FilePath-  , _ws       :: Maybe BS8.ByteString-  , _rev      :: [(Maybe BS8.ByteString, BS8.ByteString, BS8.ByteString)]-  , _doh      :: Maybe String-  , _hide     :: Bool-  , _naive    :: Bool-  , _name     :: BS8.ByteString-  , _acme     :: Maybe BS8.ByteString-  , _log      :: String-  , _loglevel :: LogLevel+  { _bind     :: !(Maybe String)+  , _port     :: !Int+  , _ssl      :: ![(String, CertFile)]+  , _auth     :: !(Maybe FilePath)+  , _ws       :: !(Maybe BS8.ByteString)+  , _rev      :: ![(Maybe BS8.ByteString, BS8.ByteString, BS8.ByteString)]+  , _doh      :: !(Maybe String)+  , _hide     :: !Bool+  , _naive    :: !Bool+  , _name     :: !BS8.ByteString+  , _acme     :: !(Maybe BS8.ByteString)+  , _log      :: !String+  , _loglevel :: !LogLevel+#ifdef OS_UNIX+  , _user     :: !(Maybe String)+  , _group    :: !(Maybe String)+#endif #ifdef QUIC_ENABLED-  , _quic     :: Maybe Int+  , _quic     :: !(Maybe Int) #endif   }  -- | Default value of 'Config', same as running @hprox@ without arguments defaultConfig :: Config defaultConfig = Config Nothing 3000 [] Nothing Nothing [] Nothing False False "hprox" Nothing "stdout" INFO+#ifdef OS_UNIX+  Nothing+  Nothing+#endif #ifdef QUIC_ENABLED     Nothing #endif  -- | Certificate file pairs data CertFile = CertFile-  { certfile :: FilePath-  , keyfile  :: FilePath+  { certfile :: !FilePath+  , keyfile  :: !FilePath   }  readCert :: CertFile -> IO TLS.Credential@@ -110,8 +125,8 @@ parser = info (helper <*> ver <*> config) (fullDesc <> progDesc desc)   where     parseSSL s = case splitBy ':' s of-        [host, cert, key] -> Right (host, CertFile cert key)-        _                 -> Left "invalid format for ssl certificates"+        host :| [cert, key] -> Right (host, CertFile cert key)+        _otherwise          -> Left "invalid format for ssl certificates"      parseRev0 s@('/':_) = case elemIndices '/' s of         []      -> Nothing@@ -143,6 +158,10 @@                     <*> acme                     <*> logging                     <*> loglevel+#ifdef OS_UNIX+                    <*> user+                    <*> group+#endif #ifdef QUIC_ENABLED                     <*> quic #endif@@ -221,6 +240,20 @@        <> value INFO        <> help "Specify the logging level (default: info)") +#ifdef OS_UNIX+    user = optional $ strOption+        ( long "user"+       <> short 'u'+       <> metavar "nobody"+       <> help "Drop root priviledge and setuid to the specified user (like nobody)")++    group = optional $ strOption+        ( long "group"+       <> short 'g'+       <> metavar "nogroup"+       <> help "Drop root priviledge and setgid to the specified group")+#endif+ #ifdef QUIC_ENABLED     quic = optional $ option auto         ( long "quic"@@ -235,6 +268,48 @@ getLoggerType "stderr" = LogStderr 4096 getLoggerType file     = LogFileNoRotate file 4096 +#ifdef OS_UNIX+dropRootPriviledge :: Logger -> Maybe String -> Maybe String -> IO Bool+dropRootPriviledge _ Nothing Nothing = return False+dropRootPriviledge logger user group = do+    currentUser <- getRealUserID+    currentGroup <- getRealGroupID+    if currentUser /= 0 || currentGroup /= 0+      then do+        logger WARN $ "Unable to setuid/setgid without root priviledge" <>+                      ", userID=" <> toLogStr (show currentUser) <>+                      ", groupID=" <> toLogStr (show currentGroup)+        return False+      else do+        let abort msg = logger ERROR msg >> exitImmediately (ExitFailure 1)+        forM_ group $ \group' -> do+            logger INFO $ "setgid to " <> toLogStr group'+            getGroupEntryForName group' >>= setGroupID . groupID+            changedGroup <- getRealGroupID+            when (changedGroup == currentGroup) $ abort "failed to setgid, aborting"+        forM_ user $ \user' -> do+            logger INFO $ "setuid to " <> toLogStr user'+            getUserEntryForName user' >>= setUserID . userID+            changedUser <- getRealUserID+            when (changedUser == currentUser) $ abort "failed to setuid, aborting"+        logger DEBUG "testing setuid(0), verify that root priviledge can't be regranted"+        catch (setUserID 0) $ \(_ :: SomeException) -> logger DEBUG "setuid(0) failed as expected"+        changedUser <- getRealUserID+        when (changedUser == 0) $ abort "unable to drop root priviledge, aborting"+        return 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 = execParser parser@@ -264,17 +339,26 @@                    setLogger warpLogger $                    setOnException exceptionHandler $ #ifdef OS_UNIX-                   setGracefulShutdownTimeout (Just 3) $-                   setInstallShutdownHandler shutdownHandler $+                   setBeforeMainLoop doBeforeMainLoop $ #endif                    setNoParsePath True $                    setServerName _name defaultSettings  #ifdef OS_UNIX-        shutdownHandler closeSocket = do-            void $ installHandler sigTERM (CatchOnce $ logger INFO "Received SIGTERM signal, shutting down gracefully" >> closeSocket) Nothing-            void $ installHandler sigINT (CatchOnce $ logger INFO "Received SIGINT signal, shutting down gracefully" >> closeSocket) Nothing+        doBeforeMainLoop = do+            dropped <- dropRootPriviledge logger _user _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+            return () #endif+#endif          exceptionHandler req ex             | _loglevel > DEBUG                                 = return ()@@ -290,7 +374,7 @@             | Just ConnectionClosedByPeer <- fromException ex   = return ()             | otherwise                                         =                 logger DEBUG $ "exception: " <> toLogStr (displayException ex) <>-                    (if isJust req then " from: " <> logRequest (fromJust req) else "")+                    maybe "" (\req' -> " from: " <> logRequest req') req          warpLogger req status _             | rawPathInfo req == "/.hprox/health" = return ()@@ -298,17 +382,20 @@                 logger TRACE $ "(" <> toLogStr (HT.statusCode status) <> ") " <> logRequest req          -- https://www.ssllabs.com/ssltest+        -- https://github.com/haskell-tls/hs-tls/blob/master/core/Network/TLS/Extra/Cipher.hs         weak_ciphers = [ TLS.cipher_ECDHE_RSA_AES256CBC_SHA384                        , TLS.cipher_ECDHE_RSA_AES256CBC_SHA                        , TLS.cipher_AES256CCM_SHA256                        , TLS.cipher_AES256GCM_SHA384                        , TLS.cipher_AES256_SHA256                        , TLS.cipher_AES256_SHA1+                       , TLS.cipher_ECDHE_ECDSA_AES256CBC_SHA384+                       , TLS.cipher_ECDHE_ECDSA_AES256CBC_SHA                        ]          tlsset = defaultTlsSettings             { tlsServerHooks     = def { TLS.onServerNameIndication = onSNI }-            , tlsCredentials     = Just (TLS.Credentials certs)+            , tlsCredentials     = Just (TLS.Credentials [head certs])             , onInsecure         = AllowInsecure             , tlsAllowedVersions = [TLS.TLS13, TLS.TLS12]             , tlsCiphers         = TLS.ciphersuite_strong \\ weak_ciphers@@ -334,7 +421,7 @@         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 certs+            , Q.scCredentials    = TLS.Credentials [head certs]             , Q.scCiphers        = Q.scCiphers Q.defaultServerConfig \\ weak_ciphers             , Q.scALPN           = Just alpn             , Q.scTlsHooks       = def { TLS.onServerNameIndication = onSNI }@@ -391,9 +478,9 @@                 httpProxy pset manager $                 reverseProxy pset manager fallback -    when (isJust _ws) $ logger INFO $ "websocket redirect: " <> toLogStr (fromJust _ws)+    forM_ _ws $ \ws -> logger INFO $ "websocket redirect: " <> toLogStr ws     unless (null revSorted) $ logger INFO $ "reverse proxy: " <> toLogStr (show revSorted)-    when (isJust _doh) $ logger INFO $ "DNS-over-HTTPS redirect: " <> toLogStr (fromJust _doh)+    forM_ _doh $ \doh -> logger INFO $ "DNS-over-HTTPS redirect: " <> toLogStr doh      case _doh of         Nothing  -> runner proxy

@@ -11,7 +11,7 @@ import Data.ByteString.Char8      qualified as BS8 import Data.ByteString.Lazy       qualified as LBS import Network.DNS-    (DNSHeader (..), DNSMessage (..), Question (..), ResolvConf (..), Resolver)+    (DNSHeader(..), DNSMessage(..), Question(..), ResolvConf(..), Resolver) import Network.DNS                qualified as DNS import Network.HTTP.Types         qualified as HT @@ -47,7 +47,7 @@         dnsQuery <- getRequestBodyChunk req         case DNS.decode dnsQuery of             Right (DNSMessage { question = [q], header = DNSHeader {..} }) -> handleQuery identifier q-            _ -> respond errorResp+            _otherwise                                                     -> respond errorResp     | otherwise = respond errorResp   where     errorResp = responseLBS HT.status400 [("Content-Type", "text/plain")] "invalid dns-over-https request"

@@ -2,8 +2,9 @@ -- -- Copyright (C) 2023 Bin Jin. All Rights Reserved. +{-# LANGUAGE ViewPatterns #-} module Network.HProx.Impl-  ( ProxySettings (..)+  ( ProxySettings(..)   , acmeProvider   , forceSSL   , healthCheckProvider@@ -18,7 +19,7 @@ import Control.Applicative        ((<|>)) import Control.Concurrent.Async   (cancel, wait, waitEither, withAsync) import Control.Exception          (SomeException, try)-import Control.Monad              (unless, void, when)+import Control.Monad              (forM_, unless, void, when) import Control.Monad.IO.Class     (liftIO) import Data.Binary.Builder        qualified as BB import Data.ByteString            qualified as BS@@ -31,9 +32,8 @@ import Data.Text.Encoding         qualified as TE import Network.HTTP.Client        qualified as HC import Network.HTTP.ReverseProxy-    (ProxyDest (..), SetIpHeader (..), WaiProxyResponse (..),-    defaultWaiProxySettings, waiProxyToSettings, wpsSetIpHeader,-    wpsUpgradeToRaw)+    (ProxyDest(..), SetIpHeader(..), WaiProxyResponse(..), defaultWaiProxySettings,+    waiProxyToSettings, wpsSetIpHeader, wpsUpgradeToRaw) import Network.HTTP.Types         qualified as HT import Network.HTTP.Types.Header  qualified as HT import System.Timeout             (timeout)@@ -48,14 +48,14 @@ import Network.HProx.Util  data ProxySettings = ProxySettings-  { proxyAuth      :: Maybe (BS.ByteString -> Bool)-  , passPrompt     :: Maybe BS.ByteString-  , wsRemote       :: Maybe BS.ByteString-  , revRemoteMap   :: [(Maybe BS.ByteString, BS.ByteString, BS.ByteString)]-  , hideProxyAuth  :: Bool-  , naivePadding   :: Bool-  , acmeThumbprint :: Maybe BS.ByteString-  , logger         :: Logger+  { proxyAuth      :: !(Maybe (BS.ByteString -> Bool))+  , passPrompt     :: !(Maybe BS.ByteString)+  , wsRemote       :: !(Maybe BS.ByteString)+  , revRemoteMap   :: ![(Maybe BS.ByteString, BS.ByteString, BS.ByteString)]+  , hideProxyAuth  :: !Bool+  , naivePadding   :: !Bool+  , acmeThumbprint :: !(Maybe BS.ByteString)+  , logger         :: !Logger   }  logRequest :: Request -> LogStr@@ -103,17 +103,23 @@ isToStripHeader h = isProxyHeader h || isForwardedHeader h || isCDNHeader h || h == "X-Real-IP" || h == "X-Scheme"  checkAuth :: ProxySettings -> Request -> Bool-checkAuth ProxySettings{..} req-    | isNothing proxyAuth = True-    | isNothing authRsp   = False-    | otherwise           =-        pureLogger logger TRACE (authMsg <> " request (credential: " <> toLogStr decodedRsp <> ") from " <> toLogStr (show (remoteHost req))) authorized+checkAuth ProxySettings{..} req = case (proxyAuth, authRsp) of+    (Nothing, _)                -> True+    (_, Nothing)                -> False+    (Just check, Just provided) ->+        let decoded = decodeLenient $ snd $ BS8.spanEnd (/=' ') provided+            authorized = check decoded+            authMsg = if authorized then "authorized" else "unauthorized"+            logMsg = authMsg <> " request (credential: " <> toLogStr decoded <> ") from "+                             <> toLogStr (show (remoteHost req))+        in pureLogger logger TRACE logMsg authorized   where     authRsp = lookup HT.hProxyAuthorization (requestHeaders req)-    decodedRsp = decodeLenient $ snd $ BS8.spanEnd (/=' ') $ fromJust authRsp -    authorized = fromJust proxyAuth decodedRsp-    authMsg = if authorized then "authorized" else "unauthorized"+parseConnectProxy :: Request -> Maybe (BS.ByteString, Int)+parseConnectProxy req+    | requestMethod req == "CONNECT" = parseHostPort (rawPathInfo req) <|> (requestHeaderHost req >>= parseHostPort)+    | otherwise                      = Nothing  redirectWebsocket :: ProxySettings -> Request -> Bool redirectWebsocket ProxySettings{..} req = wpsUpgradeToRaw defaultWaiProxySettings req && isJust wsRemote@@ -245,10 +251,11 @@                 BS.drop (BS.length rawPathPrefix) rawPath  httpConnectProxy :: ProxySettings -> Middleware-httpConnectProxy pset@ProxySettings{..} fallback req respond-    | not isConnectProxy = fallback req respond+httpConnectProxy pset@ProxySettings{..} fallback req@(parseConnectProxy -> Just (host, port)) respond     | checkAuth pset req = do-        when (isJust mPaddingType) $ logger DEBUG $ "naiveproxy padding type detected: " <> toLogStr (show (fromJust mPaddingType)) <> " for " <> logRequest req+        forM_ mPaddingType $ \paddingType ->+            logger DEBUG $ "naiveproxy padding type detected: " <> toLogStr (show paddingType) <>+                           " for " <> logRequest req         respondResponse     | hideProxyAuth      = do         logger WARN $ "unauthorized request (hidden without response): " <> logRequest req@@ -257,10 +264,6 @@         logger WARN $ "unauthorized request: " <> logRequest req         respond (proxyAuthRequiredResponse pset)   where-    hostPort' = parseHostPort (rawPathInfo req) <|> (requestHeaderHost req >>= parseHostPort)-    isConnectProxy = requestMethod req == "CONNECT" && isJust hostPort'--    Just (host, port) = hostPort'     settings = CN.clientSettings port host      backup = responseKnownLength HT.status500 [("Content-Type", "text/plain")]@@ -275,8 +278,8 @@             withAsync right $ \r -> do                 res1 <- waitEither l r                 let unfinished = case res1 of-                        Left _ -> r-                        _      -> l+                        Left _  -> r+                        Right _ -> l                 res2 <- timeout (secs * 1000000) (wait unfinished)                 when (isNothing res2) $ cancel unfinished @@ -319,3 +322,4 @@             void $ runStreams 5                 (runConduit clientToServer)                 (runConduit serverToClient)+httpConnectProxy _ fallback req respond = fallback req respond

@@ -3,11 +3,11 @@ -- Copyright (C) 2023 Bin Jin. All Rights Reserved.  module Network.HProx.Log-  ( LogLevel (..)+  ( LogLevel(..)   , LogStr-  , LogType' (..)+  , LogType'(..)   , Logger-  , ToLogStr (..)+  , ToLogStr(..)   , logLevelReader   , pureLogger   , withLogger@@ -33,7 +33,7 @@ logLevelReader "warn"  = Just WARN logLevelReader "error" = Just ERROR logLevelReader "none"  = Just NONE-loglevelReader _       = Nothing+logLevelReader _       = Nothing  logWith :: TimedFastLogger -> LogLevel -> LogStr -> IO () logWith logger level logstr = logger (\time -> toLogStr time <> " [" <> toLogStr (show level) <> "] " <> logstr <> "\n")

@@ -3,7 +3,7 @@ -- Copyright (C) 2023 Bin Jin. All Rights Reserved.  module Network.HProx.Naive-  ( PaddingType (..)+  ( PaddingType(..)   , addPaddingConduit   , parseRequestForPadding   , prepareResponseForPadding@@ -20,8 +20,7 @@ import Data.Maybe                (mapMaybe) import Network.HTTP.Types.Header qualified as HT import System.Random             (uniformR)-import System.Random.Stateful-    (applyAtomicGen, globalStdGen, runStateGen, uniformRM)+import System.Random.Stateful    (applyAtomicGen, globalStdGen, runStateGen, uniformRM)  import Data.Conduit import Network.Wai@@ -131,4 +130,4 @@             if LBS.length bs /= len + paddingLen                 then return ()                 else yield (LBS.toStrict $ LBS.take len bs) >> removePaddingVariant1 (n - 1)-        _ -> return ()+        _otherwise   -> return ()

@@ -3,8 +3,8 @@ -- Copyright (C) 2023 Bin Jin. All Rights Reserved.  module Network.HProx.Util-  ( Password (..)-  , PasswordSalted (..)+  ( Password(..)+  , PasswordSalted(..)   , hashPasswordWithRandomSalt   , parseHostPort   , parseHostPortWithDefault@@ -18,36 +18,38 @@ import Data.ByteString       qualified as BS import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy  qualified as LBS+import Data.List.NonEmpty    (NonEmpty(..), (<|))+import Data.List.NonEmpty    qualified as NE import Data.Maybe            (fromMaybe)  import Network.HTTP.Types (ResponseHeaders, Status) import Network.Wai -import Crypto.Error           (CryptoFailable (..))+import Crypto.Error           (CryptoFailable(..)) import Crypto.KDF.Argon2      qualified as Argon2-import Crypto.Random          (MonadRandom (getRandomBytes))+import Crypto.Random          (MonadRandom(getRandomBytes)) import Data.ByteString.Base64 qualified as Base64 -data Password = PlainText BS.ByteString-              | Salted BS.ByteString BS.ByteString+data Password = PlainText !BS.ByteString+              | Salted !BS.ByteString !BS.ByteString     deriving (Show, Eq) -data PasswordSalted = PasswordSalted BS.ByteString BS.ByteString+data PasswordSalted = PasswordSalted !BS.ByteString !BS.ByteString     deriving (Show, Eq) -splitBy :: Eq a => a -> [a] -> [[a]]-splitBy _ [] = [[]]+splitBy :: Eq a => a -> [a] -> NonEmpty [a]+splitBy _ [] = NE.singleton [] splitBy c (x:xs)-  | c == x    = [] : splitBy c xs-  | otherwise = let y:ys = splitBy c xs in (x:y):ys+  | c == x    = [] <| splitBy c xs+  | otherwise = let y :| ys = splitBy c xs in (x:y) :| ys  passwordReader :: BS.ByteString -> Maybe (BS.ByteString, Password) passwordReader line = case BS8.split ':' line of     [user, pass]         -> Just (user, PlainText pass)     [user, salt, hashed] -> case (Base64.decode salt, Base64.decode hashed) of                                 (Right salt', Right hashed') -> Just (user, Salted salt' hashed')-                                _                            -> Nothing-    _                    -> Nothing+                                _otherwise                   -> Nothing+    _otherwise           -> Nothing  passwordWriter :: BS.ByteString -> PasswordSalted -> BS.ByteString passwordWriter user (PasswordSalted salt hash) =