diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -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 diff --git a/cbits/setcap.c b/cbits/setcap.c new file mode 100644 --- /dev/null +++ b/cbits/setcap.c @@ -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 +#include +#include +#include +#include +#include +#include +#include +#include + +#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 diff --git a/hprox.cabal b/hprox.cabal --- a/hprox.cabal +++ b/hprox.cabal @@ -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 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 diff --git a/src/Network/HProx.hs b/src/Network/HProx.hs --- a/src/Network/HProx.hs +++ b/src/Network/HProx.hs @@ -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 diff --git a/src/Network/HProx/DoH.hs b/src/Network/HProx/DoH.hs --- a/src/Network/HProx/DoH.hs +++ b/src/Network/HProx/DoH.hs @@ -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" diff --git a/src/Network/HProx/Impl.hs b/src/Network/HProx/Impl.hs --- a/src/Network/HProx/Impl.hs +++ b/src/Network/HProx/Impl.hs @@ -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 diff --git a/src/Network/HProx/Log.hs b/src/Network/HProx/Log.hs --- a/src/Network/HProx/Log.hs +++ b/src/Network/HProx/Log.hs @@ -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") diff --git a/src/Network/HProx/Naive.hs b/src/Network/HProx/Naive.hs --- a/src/Network/HProx/Naive.hs +++ b/src/Network/HProx/Naive.hs @@ -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 () diff --git a/src/Network/HProx/Util.hs b/src/Network/HProx/Util.hs --- a/src/Network/HProx/Util.hs +++ b/src/Network/HProx/Util.hs @@ -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) =