http-proxy 0.0.6 → 0.0.7
raw patch · 3 files changed
+216/−90 lines, 3 filesdep ~blaze-builder-conduitdep ~conduitdep ~wai
Dependency ranges changed: blaze-builder-conduit, conduit, wai
Files
- Network/HTTP/Proxy.hs +202/−76
- Network/HTTP/Proxy/ReadInt.hs +1/−1
- http-proxy.cabal +13/−13
Network/HTTP/Proxy.hs view
@@ -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 ->
Network/HTTP/Proxy/ReadInt.hs view
@@ -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
http-proxy.cabal view
@@ -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