diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs --- a/Network/HTTP/Proxy.hs +++ b/Network/HTTP/Proxy.hs @@ -92,9 +92,10 @@ import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI import System.IO (hPutStrLn, stderr) -import Network.HTTP.Proxy.ReadInt (readInt64) import qualified Data.IORef as I import Data.String (IsString (..)) +import qualified Data.ByteString.Lex.Integral as LI +import Network.TLS (TLSCertificateUsage (..)) #if WINDOWS import Control.Concurrent (threadDelay) @@ -159,9 +160,16 @@ addrs <- getAddrInfo (Just hints) host port -- Choose an IPv6 socket if exists. This ensures the socket can -- handle both IPv4 and IPv6 if v6only is false. - let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs ++ filter (\x -> addrFamily x /= AF_INET6) addrs + let addrs4 = filter (\x -> addrFamily x /= AF_INET6) addrs + addrs6 = filter (\x -> addrFamily x == AF_INET6) addrs + addrs' = + case s of + HostIPv4 -> addrs4 ++ addrs6 + HostIPv6 -> addrs6 ++ addrs4 + _ -> addrs - tryAddrs (addr1:rest@(_:_)) = catch + tryAddrs (addr1:rest@(_:_)) = + catch (theBody addr1) (\(_ :: IOException) -> tryAddrs rest) tryAddrs (addr1:[]) = theBody addr1 @@ -171,7 +179,6 @@ (Network.Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) sClose (\sock -> do - putStrLn $ show addr ++ " out of " ++ show addrs setSocketOption sock ReuseAddr 1 bindSocket sock (addrAddress addr) listen sock maxListenQueue @@ -221,13 +228,14 @@ let onE = proxyOnException set port = proxyPort set tm <- T.initialize $ proxyTimeout set * 1000000 - mgr <- HC.newManager HC.def forever $ do (conn, addr) <- getConn _ <- forkIO $ do + mgr <- HC.newManager managerSettingsNoCheck th <- T.registerKillThread tm serveConnection set th tm onE port conn addr mgr T.cancel th + HC.closeManager mgr return () serveConnection :: Settings @@ -260,14 +268,14 @@ Just s -> do let (hs, ps) = case S.split 58 s of -- ':' [h] -> (h, if isSecure req then 443 else 80) - [h, p] -> (h, readInt p) + [h, p] -> (h, LI.readDecimal_ p) _ -> (serverName req, serverPort req) modReq <- liftIO $ proxyRequestModifier settings req { serverName = hs, serverPort = ps } proxyPlain th conn mgr modReq >>= \keepAlive -> when keepAlive $ serveConnection'' fromClient _ | requestMethod req == "CONNECT" -> case B.split ':' (rawPathInfo req) of - [h, p] -> proxyConnect th tm conn h (readInt p) req + [h, p] -> proxyConnect th tm conn h (LI.readDecimal_ p) req >>= \keepAlive -> when keepAlive $ serveConnection'' fromClient _ -> failRequest th conn req "Bad request" ("Bad request '" `mappend` rawPathInfo req `mappend` "'.") >>= \keepAlive -> when keepAlive $ serveConnection'' fromClient @@ -331,7 +339,7 @@ let len0 = case lookup "content-length" heads of Nothing -> 0 - Just bs -> readInt bs + Just bs -> LI.readDecimal_ bs let serverName' = takeUntil 58 host -- ':' rbody <- if len0 == 0 @@ -643,7 +651,7 @@ Just x -> go x Nothing -> when (go' $ fromException e) - $ hPutStrLn stderr $ show e + $ hPutStrLn stderr $ "ProxyEx: " ++ show e , proxyTimeout = 30 , proxyRequestModifier = return . id } @@ -716,11 +724,7 @@ else pos {-# INLINE checkCR #-} -readInt :: Integral a => ByteString -> a -readInt bs = fromIntegral $ readInt64 bs -{-# INLINE readInt #-} - serverHeader :: H.RequestHeaders -> H.RequestHeaders serverHeader hdrs = case lookup key hdrs of Nothing -> server : hdrs @@ -753,12 +757,13 @@ -- liftIO $ putStrLn $ B.unpack (requestMethod req) ++ " " ++ B.unpack urlStr let contentLength = if requestMethod req == "GET" then 0 - else readInt . fromMaybe "0" . lookup "content-length" . requestHeaders $ req + else LI.readDecimal_ . fromMaybe "0" . lookup "content-length" . requestHeaders $ req url <- (\u -> u { HC.method = requestMethod req , HC.requestHeaders = outHdrs , HC.rawBody = True + , HC.secure = isSecure req , HC.requestBody = HC.RequestBodySource contentLength $ fmap copyByteString $ requestBody req @@ -855,5 +860,6 @@ _ -> firstSuccessful ps - - +managerSettingsNoCheck :: HC.ManagerSettings +managerSettingsNoCheck = + HC.def { HC.managerCheckCerts = \ _ _ -> return CertificateUsageAccept } diff --git a/Network/HTTP/Proxy/ReadInt.hs b/Network/HTTP/Proxy/ReadInt.hs deleted file mode 100644 --- a/Network/HTTP/Proxy/ReadInt.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE OverloadedStrings, MagicHash, BangPatterns #-} - --- Copyright : Erik de Castro Lopo --- License : BSD3 - -module Network.HTTP.Proxy.ReadInt (readInt64) where - --- This function lives in its own file because the MagicHash pragma interacts --- poorly with the CPP pragma. - -import Data.ByteString (ByteString) -import Data.Int (Int64) -import GHC.Prim -import GHC.Types - -import qualified Data.ByteString.Char8 as B -import qualified Data.Char as C - --- This function is used to parse the Content-Length field of HTTP headers and --- is a performance hot spot. It should only be replaced with something --- significantly and provably faster. --- --- It needs to be able work correctly on 32 bit CPUs for file sizes > 2G so we --- use Int64 here and then make a generic 'readInt' that allows conversion to --- Int and Integer. - -readInt64 :: ByteString -> Int64 -readInt64 bs = - B.foldl' (\i c -> i * 10 + fromIntegral (mhDigitToInt c)) 0 - $ B.takeWhile C.isDigit bs -{- NOINLINE readInt64MH #-} - -data Table = Table !Addr# - -{- NOINLINE mhDigitToInt #-} -mhDigitToInt :: Char -> Int -mhDigitToInt (C# i) = I# (word2Int# (indexWord8OffAddr# addr (ord# i))) - where - !(Table addr) = table - table :: Table - table = Table - "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\ - \\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# - diff --git a/http-proxy.cabal b/http-proxy.cabal --- a/http-proxy.cabal +++ b/http-proxy.cabal @@ -1,5 +1,5 @@ Name: http-proxy -Version: 0.0.8 +Version: 0.0.9 License: BSD3 License-file: LICENSE Author: Michael Snoyman, Stephen Blackheath, Erik de Castro Lopo @@ -33,13 +33,15 @@ , bytestring >= 0.9.1.4 && < 0.10 , wai >= 1.1 && < 1.2 , conduit >= 0.2 && < 0.3 - , http-conduit >= 1.2 && < 1.3 + , http-conduit >= 1.2.6 && < 1.3 , transformers >= 0.2.2 && < 0.3 , blaze-builder >= 0.2.1.4 && < 0.4 , http-types >= 0.6 && < 0.7 , case-insensitive >= 0.4 && < 0.5 , lifted-base >= 0.1 && < 0.2 , blaze-builder-conduit >= 0.2 && < 0.3 + , tls >= 0.9 && < 0.10 + , bytestring-lexing >= 0.4 && < 0.5 , ghc-prim if flag(network-bytestring) build-depends: network >= 2.2.1.5 && < 2.2.3 @@ -48,7 +50,6 @@ build-depends: network >= 2.3 && < 2.4 Exposed-modules: Network.HTTP.Proxy Other-modules: Network.HTTP.Proxy.Timeout - Network.HTTP.Proxy.ReadInt ghc-options: -Wall -fwarn-tabs if os(windows)