diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs --- a/Network/HTTP/Proxy.hs +++ b/Network/HTTP/Proxy.hs @@ -73,14 +73,13 @@ import Control.Monad.Trans.Resource (ResourceT, runResourceT, with) import qualified Data.Conduit as C -import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.Blaze (builderToByteString) import Control.Exception.Lifted (throwIO) import Blaze.ByteString.Builder.HTTP (chunkedTransferEncoding, chunkedTransferTerminator) import Blaze.ByteString.Builder - (copyByteString, Builder, toLazyByteString, toByteStringIO) + (copyByteString, Builder, toLazyByteString, toByteStringIO, flush) import Blaze.ByteString.Builder.Char8 (fromChar, fromShow) import Data.Monoid (mappend, mempty) @@ -94,6 +93,8 @@ 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 (..)) #if WINDOWS import Control.Concurrent (threadDelay) @@ -144,29 +145,40 @@ } -bindPort :: Int -> String -> IO Socket +bindPort :: Int -> HostPreference -> IO Socket bindPort p s = do let hints = defaultHints { addrFlags = [AI_PASSIVE , AI_NUMERICSERV , AI_NUMERICHOST] , addrSocketType = Stream } - host = if s == "*" then Nothing else Just s + host = + case s of + Host s' -> Just s' + _ -> Nothing port = Just . show $ p 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 - addr = if null addrs' then head addrs else head addrs' - bracketOnError - (Network.Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) - sClose - (\sock -> do - setSocketOption sock ReuseAddr 1 - bindSocket sock (addrAddress addr) - listen sock maxListenQueue - return sock - ) + let addrs' = filter (\x -> addrFamily x == AF_INET6) addrs ++ filter (\x -> addrFamily x /= AF_INET6) addrs + tryAddrs (addr1:rest@(_:_)) = catch + (theBody addr1) + (\(_ :: IOException) -> tryAddrs rest) + tryAddrs (addr1:[]) = theBody addr1 + tryAddrs _ = error "bindPort: addrs is empty" + theBody addr = + bracketOnError + (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 + return sock + ) + tryAddrs addrs' + -- | Run a HTTP and HTTPS proxy server on the specified port. This calls -- 'runProxySettings' with 'defaultSettings'. runProxy :: Port -> IO () @@ -235,17 +247,24 @@ where serveConnection' :: ResourceT IO () serveConnection' = do - fromClient <- C.bufferSource $ C.Source $ return $ connSource conn th + fromClient <- C.bufferSource $ connSource conn th serveConnection'' fromClient serveConnection'' fromClient = do - req <- parseRequest port remoteHost' fromClient - --liftIO $ print $ requestHeaders req + req <- parseRequest conn port remoteHost' fromClient case req of - _ | requestMethod req `elem` [ "GET", "POST" ] -> - liftIO (proxyRequestModifier settings req) - >>= proxyPlain th conn mgr - >>= \keepAlive -> when keepAlive $ serveConnection'' fromClient + _ | requestMethod req `elem` [ "GET", "POST" ] -> do + case lookup "host" (requestHeaders req) of + Nothing -> failRequest th conn req "Bad proxy request" ("Request '" `mappend` rawPathInfo req `mappend` "'.") + >>= \keepAlive -> when keepAlive $ serveConnection'' fromClient + 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) + _ -> (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 @@ -256,12 +275,12 @@ failRequest th conn req "Unknown request" ("Unknown request '" `mappend` rawPathInfo req `mappend` "'.") >>= \keepAlive -> when keepAlive $ serveConnection'' fromClient -parseRequest :: Port -> SockAddr +parseRequest :: Connection -> Port -> SockAddr -> C.BufferedSource IO S.ByteString -> ResourceT IO Request -parseRequest port remoteHost' src = do +parseRequest conn port remoteHost' src = do headers' <- src C.$$ takeHeaders - parseRequest' port headers' remoteHost' src + parseRequest' conn port headers' remoteHost' src -- FIXME come up with good values here bytesPerRead, maxTotalHeaderLength :: Int @@ -277,32 +296,94 @@ deriving (Show, Typeable, Eq) instance Exception InvalidRequest +handleExpect :: Connection + -> H.HttpVersion + -> ([H.Header] -> [H.Header]) + -> [H.Header] + -> IO [H.Header] +handleExpect _ _ front [] = return $ front [] +handleExpect conn hv front (("expect", "100-continue"):rest) = do + connSendAll conn $ + if hv == H.http11 + then "HTTP/1.1 100 Continue\r\n\r\n" + else "HTTP/1.0 100 Continue\r\n\r\n" + return $ front rest +handleExpect conn hv front (x:xs) = handleExpect conn hv (front . (x:)) xs + -- | Parse a set of header lines and body into a 'Request'. -parseRequest' :: Port +parseRequest' :: Connection + -> Port -> [ByteString] -> SockAddr -> C.BufferedSource IO S.ByteString -> ResourceT IO Request -parseRequest' _ [] _ _ = throwIO $ NotEnoughLines [] -parseRequest' port (firstLine:otherLines) remoteHost' src = do +parseRequest' _ _ [] _ _ = throwIO $ NotEnoughLines [] +parseRequest' conn port (firstLine:otherLines) remoteHost' src = do (method, rpath', gets, httpversion) <- parseFirst firstLine let (host',rpath) | S.null rpath' = ("", "/") | "http://" `S.isPrefixOf` rpath' = S.breakByte 47 $ S.drop 7 rpath' | otherwise = ("", rpath') - let heads = map parseHeaderNoAttr otherLines + heads <- liftIO + $ handleExpect conn httpversion id + (map parseHeaderNoAttr otherLines) let host = fromMaybe host' $ lookup "host" heads - let len = + let len0 = case lookup "content-length" heads of Nothing -> 0 Just bs -> readInt bs let serverName' = takeUntil 58 host -- ':' - -- FIXME isolate takes an Integer instead of Int or Int64. If this is a - -- performance penalty, we may need our own version. - rbody <- C.prepareSource $ - if len == 0 - then mempty - else src C.$= CB.isolate len + rbody <- + if len0 == 0 + then return mempty + else do + -- We can't use the standard isolate, as its counter is not + -- kept in a mutable variable. + lenRef <- liftIO $ I.newIORef len0 + let isolate = C.Conduit push close + push bs = do + len <- liftIO $ I.readIORef lenRef + let (a, b) = S.splitAt len bs + len' = len - S.length a + liftIO $ I.writeIORef lenRef len' + return $ if len' == 0 + then C.Finished (if S.null b then Nothing else Just b) (if S.null a then [] else [a]) + else C.Producing isolate [a] + close = return [] + + -- Make sure that we don't connect to the source after the + -- isolate conduit closes. + -- + -- Here's the issue: we fuse our buffered request body with + -- an isolate conduit which ensures no more than X bytes + -- are read. Suppose we read all X bytes, and then we call + -- requestBody again. What happens? + -- + -- Previously, we would try to read one more chunk from the + -- buffered source. This is inherent to conduit: we + -- wouldn't know that the isolate Conduit isn't accepting + -- more data until after we've pushed some data to it. This + -- results in hanging, since there's no data available on + -- the wire. + -- + -- Instead, we add a wrapper that checks if the request + -- body has already been depleted before making that first + -- pull. + -- + -- Possible optimization: do away with the Conduit + -- entirely. However, this may be less efficient overall, + -- as we'd now have to check the BufferedSource status on + -- each call. Worth looking into. + + wrap src' = C.Source + { C.sourcePull = do + len <- liftIO $ I.readIORef lenRef + if len <= 0 + then return C.Closed + else C.sourcePull src' + , C.sourceClose = return () + } + return $ wrap $ src C.$= isolate return Request { requestMethod = method , httpVersion = httpversion @@ -315,7 +396,7 @@ , requestHeaders = heads , isSecure = False , remoteHost = remoteHost' - , requestBody = C.Source $ return rbody + , requestBody = rbody , vault = mempty } @@ -434,9 +515,12 @@ `mappend` chunkedTransferTerminator else headers' False `mappend` b - sendResponse' (ResponseSource s hs body) = + sendResponse' (ResponseSource s hs bodyFlush) = response where + body = fmap (\x -> case x of + C.Flush -> flush + C.Chunk builder -> builder) bodyFlush headers' = headers version s hs -- FIXME perhaps alloca a buffer per thread and reuse that in all -- functions below. Should lessen greatly the GC burden (I hope) @@ -455,12 +539,13 @@ return $ isKeepAlive hs needsChunked' = needsChunked hs chunk :: C.Conduit Builder IO Builder - chunk = C.Conduit $ return C.PreparedConduit + chunk = C.Conduit { C.conduitPush = push , C.conduitClose = close } - push x = return $ C.Producing [chunkedTransferEncoding x] + conduit = C.Conduit push close + push x = return $ C.Producing conduit [chunkedTransferEncoding x] close = return [chunkedTransferTerminator] parseHeaderNoAttr :: ByteString -> H.Header @@ -473,31 +558,33 @@ else rest in (CI.mk k, rest') -connSource :: Connection -> T.Handle -> C.PreparedSource IO ByteString -connSource Connection { connRecv = recv } th = C.PreparedSource - { C.sourcePull = do - bs <- liftIO recv - if S.null bs - then return C.Closed - else do - when (S.length bs >= 2048) $ liftIO $ T.tickle th - return (C.Open bs) - , C.sourceClose = return () - } +connSource :: Connection -> T.Handle -> C.Source IO ByteString +connSource Connection { connRecv = recv } th = + src + where + src = C.Source + { C.sourcePull = do + bs <- liftIO recv + if S.null bs + then return C.Closed + else do + when (S.length bs >= 2048) $ liftIO $ T.tickle th + return (C.Open src bs) + , C.sourceClose = return () + } -- | Use 'connSendAll' to send this data while respecting timeout rules. connSink :: Connection -> T.Handle -> C.Sink B.ByteString IO () -connSink Connection { connSendAll = send } th = C.Sink $ return C.SinkData - { C.sinkPush = push - , C.sinkClose = close - } +connSink Connection { connSendAll = send } th = + C.SinkData push close where close = liftIO (T.resume th) push x = do - liftIO $ T.resume th - liftIO $ send x - liftIO $ T.pause th - return C.Processing + liftIO $ do + T.resume th + send x + T.pause th + return (C.Processing push close) -- We pause timeouts before passing control back to user code. This ensures -- that a timeout will only ever be executed when Warp is in control. We -- also make sure to resume the timeout after the completion of user code @@ -515,12 +602,44 @@ -- > defaultSettings { proxyPort = 3128 } data Settings = Settings { proxyPort :: Int -- ^ Port to listen on. Default value: 3100 - , proxyHost :: String -- ^ Host to bind to, or * for all. Default value: * + , proxyHost :: HostPreference -- ^ Default value: HostIPv4 , proxyOnException :: SomeException -> IO () -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr. , proxyTimeout :: Int -- ^ Timeout value in seconds. Default value: 30 , proxyRequestModifier :: Request -> IO Request -- ^ A function that allows the the request to be modified before being run. Default: 'return . id'. } +-- | Which host to bind. +-- +-- Note: The @IsString@ instance recognizes the following special values: +-- +-- * @*@ means @HostAny@ +-- +-- * @*4@ means @HostIPv4@ +-- +-- * @*6@ means @HostIPv6@ +data HostPreference = + HostAny + | HostIPv4 + | HostIPv6 + | Host String + deriving (Show, Eq, Ord) + +instance IsString HostPreference where + -- The funny code coming up is to get around some irritating warnings from + -- GHC. I should be able to just write: + {- + fromString "*" = HostAny + fromString "*4" = HostIPv4 + fromString "*6" = HostIPv6 + -} + fromString s'@('*':s) = + case s of + [] -> HostAny + ['4'] -> HostIPv4 + ['6'] -> HostIPv6 + _ -> Host s' + fromString s = Host s + -- | The default settings for the Proxy server. See the individual settings for -- the default value. defaultSettings :: Settings @@ -559,7 +678,7 @@ takeHeadersPush :: THStatus -> ByteString - -> ResourceT IO (THStatus, C.SinkResult ByteString [ByteString]) + -> ResourceT IO (C.SinkStateResult THStatus ByteString [ByteString]) takeHeadersPush (THStatus len _ _ ) _ | len > maxTotalHeaderLength = throwIO OverLargeHeader takeHeadersPush (THStatus len lines prepend) bs = @@ -567,7 +686,7 @@ -- no newline. prepend entire bs to next line Nothing -> do let len' = len + bsLen - return (THStatus len' lines (prepend . S.append bs), C.Processing) + return $ C.StateProcessing $ THStatus len' lines (prepend . S.append bs) Just nl -> do let end = nl start = nl + 1 @@ -581,8 +700,8 @@ if start < bsLen then do let rest = SU.unsafeDrop start bs - return (undefined, C.Done (Just rest) lines') - else return (undefined, C.Done Nothing lines') + return $ C.StateDone (Just rest) lines' + else return $ C.StateDone Nothing lines' -- more headers else do let len' = len + start @@ -591,7 +710,7 @@ then do let more = SU.unsafeDrop start bs takeHeadersPush (THStatus len' lines' id) more - else return (THStatus len' lines' id, C.Processing) + else return $ C.StateProcessing $ THStatus len' lines' id where bsLen = S.length bs mnl = S.elemIndex 10 bs @@ -624,7 +743,12 @@ proxyPlain :: T.Handle -> Connection -> HC.Manager -> Request -> ResourceT IO Bool proxyPlain th conn mgr req = do - let urlStr = "http://" `mappend` serverName req + let portStr = case (serverPort req, isSecure req) of + (80, False) -> mempty + (443, True) -> mempty + (n, _) -> fromString (":" ++ show n) + urlStr = "http://" `mappend` serverName req + `mappend` portStr `mappend` rawPathInfo req `mappend` rawQueryString req close = @@ -633,20 +757,22 @@ -- RFC2616: Connection defaults to Close in HTTP/1.0 and Keep-Alive in HTTP/1.1 defaultClose = httpVersion req == H.HttpVersion 1 0 in fromMaybe defaultClose mClose - outHdrs = [(n,v) | (n,v) <- requestHeaders req, n /= "Host"] - liftIO $ putStrLn $ B.unpack (requestMethod req) ++ " " ++ B.unpack urlStr + outHdrs = [(n,v) | (n,v) <- requestHeaders req, not $ n `elem` [ "Host", "Accept-Encoding", "Content-Length" ]] + -- 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 url <- - (\u -> u { HC.method = requestMethod req, - HC.requestHeaders = outHdrs, - HC.rawBody = True, - HC.requestBody = HC.RequestBodySource contentLength + (\u -> u { HC.method = requestMethod req + , HC.requestHeaders = outHdrs + , HC.rawBody = True + , HC.requestBody = HC.RequestBodySource contentLength $ fmap copyByteString $ requestBody req - }) + -- In a proxy we do not want to intercept non-2XX status codes. + , HC.checkStatus = \ _ _ -> Nothing + }) <$> lift (HC.parseUrl (B.unpack urlStr)) HC.Response sc rh bodySource <- HC.http url mgr @@ -675,7 +801,7 @@ proxyConnect :: T.Handle -> T.Manager -> Connection -> ByteString -> Int -> Request -> ResourceT IO Bool proxyConnect th tm conn host prt req = do - liftIO $ putStrLn $ B.unpack (requestMethod req) ++ " " ++ B.unpack host ++ ":" ++ show prt + -- liftIO $ putStrLn $ B.unpack (requestMethod req) ++ " " ++ B.unpack host ++ ":" ++ show prt eConn <- liftIO $ do usock <- socketConnection `fmap` connectTo (B.unpack host) (PortNumber . fromIntegral $ prt) return $ Right usock @@ -683,7 +809,7 @@ return $ Left $ "Unable to connect: " `mappend` B.pack (show exc) case eConn of Right uconn -> do - fromUpstream <- C.bufferSource $ C.Source $ return $ connSource uconn th + fromUpstream <- C.bufferSource $ connSource uconn th liftIO $ connSendMany conn $ L.toChunks $ toLazyByteString $ headers (httpVersion req) H.statusOK [] False @@ -692,7 +818,7 @@ runResourceT (fromUpstream C.$$ connSink conn wrTh) T.cancel wrTh ) killThread - fromClient <- C.bufferSource $ C.Source $ return $ connSource conn th + fromClient <- C.bufferSource $ connSource conn th fromClient C.$$ connSink uconn th return False Left errorMsg -> diff --git a/Network/HTTP/Proxy/ReadInt.hs b/Network/HTTP/Proxy/ReadInt.hs --- a/Network/HTTP/Proxy/ReadInt.hs +++ b/Network/HTTP/Proxy/ReadInt.hs @@ -34,7 +34,7 @@ {- NOINLINE mhDigitToInt #-} mhDigitToInt :: Char -> Int -mhDigitToInt (C# i) = I# (word2Int# $ indexWord8OffAddr# addr (ord# i)) +mhDigitToInt (C# i) = I# (word2Int# (indexWord8OffAddr# addr (ord# i))) where !(Table addr) = table table :: Table 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.6 +Version: 0.0.7 License: BSD3 License-file: LICENSE Author: Michael Snoyman, Stephen Blackheath, Erik de Castro Lopo @@ -29,17 +29,17 @@ Default: False Library - Build-Depends: base >= 3 && < 5 - , bytestring >= 0.9.1.4 && < 0.10 - , wai >= 1.0 && < 1.1 - , conduit - , http-conduit >= 1.2 && < 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.0 && < 0.1 + Build-Depends: base >= 3 && < 5 + , bytestring >= 0.9.1.4 && < 0.10 + , wai >= 1.1 && < 1.2 + , conduit >= 0.2 && < 0.3 + , http-conduit >= 1.2 && < 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 , ghc-prim if flag(network-bytestring) build-depends: network >= 2.2.1.5 && < 2.2.3 @@ -50,7 +50,7 @@ Other-modules: Network.HTTP.Proxy.Timeout Network.HTTP.Proxy.ReadInt - ghc-options: -Wall + ghc-options: -Wall -fwarn-tabs if os(windows) Cpp-options: -DWINDOWS