http-proxy 0.0.5 → 0.0.6
raw patch · 3 files changed
+516/−380 lines, 3 filesdep +blaze-builder-conduitdep +conduitdep +ghc-primdep −enumeratordep −http-enumeratordep ~case-insensitivedep ~waiPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: blaze-builder-conduit, conduit, ghc-prim, http-conduit, lifted-base
Dependencies removed: enumerator, http-enumerator
Dependency ranges changed: case-insensitive, wai
API changes (from Hackage documentation)
+ Network.HTTP.Proxy: requestBody :: Request -> Source IO ByteString
+ Network.HTTP.Proxy: vault :: Request -> Vault
- Network.HTTP.Proxy: Request :: Method -> HttpVersion -> ByteString -> ByteString -> ByteString -> Int -> RequestHeaders -> Bool -> SockAddr -> [Text] -> Query -> Request
+ Network.HTTP.Proxy: Request :: Method -> HttpVersion -> ByteString -> ByteString -> ByteString -> Int -> RequestHeaders -> Bool -> SockAddr -> [Text] -> Query -> Source IO ByteString -> Vault -> Request
Files
- Network/HTTP/Proxy.hs +446/−373
- Network/HTTP/Proxy/ReadInt.hs +58/−0
- http-proxy.cabal +12/−7
Network/HTTP/Proxy.hs view
@@ -10,9 +10,11 @@ -- License : BSD3 -- -- History:--- This code originated in Michael Snoyman's Warp package, was modified by--- Stephen Blackheath to turn it into a HTTP/HTTP proxy and is now maintained--- by Erik de Castro Lopo.+-- This code originated in Michael Snoyman's Warp package when Warp was based+-- on the Data.Source library. That code was modified by Stephen Blackheath+-- to turn it into a HTTP/HTTP proxy and from there fell under the maintainership+-- of Erik de Castro Lopo who then did the conversion from Data.Enumerator to+-- Data.Conduit. During that conversion, Warp was again used as a reference. -- --------------------------------------------------------- @@ -43,6 +45,7 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as SU import qualified Data.ByteString.Char8 as B+import qualified Data.ByteString.Lazy as L import Network ( PortID(..) ) import Network.Socket@@ -50,7 +53,7 @@ , SocketType (Stream), listen, bindSocket, setSocketOption, maxListenQueue , SockAddr, SocketOption (ReuseAddr) , AddrInfo(..), AddrInfoFlag(..), defaultHints, getAddrInfo- , Socket, sClose, shutdown, ShutdownCmd(..), HostName, ServiceName, socket, connect+ , Socket, sClose, HostName, ServiceName, socket, connect ) import Network.BSD ( getProtocolNumber ) import Network.Wai@@ -62,33 +65,35 @@ , fromException, AsyncException (ThreadKilled) , bracketOnError, IOException, throw )-import Control.Concurrent (forkIO, ThreadId, killThread)--import Data.Maybe (fromMaybe, isNothing)-import qualified Network.HTTP.Enumerator as HE+import Control.Concurrent (forkIO, killThread)+import Data.Maybe (fromMaybe, isJust, isNothing)+import qualified Network.HTTP.Conduit as HC import Data.Typeable (Typeable) -import Data.Enumerator hiding (filter, head, foldl', map)-import qualified Data.Enumerator as E-import qualified Data.Enumerator.List as EL-import qualified Data.Enumerator.Binary as EB-+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, toByteString, fromByteString)+ (copyByteString, Builder, toLazyByteString, toByteStringIO) import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)-import Data.Monoid (mappend)+import Data.Monoid (mappend, mempty) import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Trans.Class (lift) import qualified Network.HTTP.Proxy.Timeout as T+import Data.Word (Word8) import Data.List (delete, foldl')-import Control.Monad (forever, when)+import Control.Monad (forever, when, void) import qualified Network.HTTP.Types as H import qualified Data.CaseInsensitive as CI import System.IO (hPutStrLn, stderr)-import Numeric (readDec)-import Data.Int (Int64)+import Network.HTTP.Proxy.ReadInt (readInt64) #if WINDOWS import Control.Concurrent (threadDelay)@@ -96,9 +101,50 @@ import Network.Socket (withSocketsDo) #endif -bindPort :: Int -- ^ Port- -> String -- ^ Bind interface or "*" for all- -> IO Socket+#if 0+import Data.Version (showVersion)+import qualified Paths_httpProxy++httpProxyVersion :: String+httpProxyVersion = showVersion Paths_warp.version+#endif++-- |+--+-- In order to provide slowloris protection, Warp provides timeout handlers. We+-- follow these rules:+--+-- * A timeout is created when a connection is opened.+--+-- * When all request headers are read, the timeout is tickled.+--+-- * Every time at least 2048 bytes of the request body are read, the timeout+-- is tickled.+--+-- * The timeout is paused while executing user code. This will apply to both+-- the application itself, and a ResponseSource response. The timeout is+-- resumed as soon as we return from user code.+--+-- * Every time data is successfully sent to the client, the timeout is tickled.+data Connection = Connection+ { connSendMany :: [B.ByteString] -> IO ()+ , connSendAll :: B.ByteString -> IO ()+ , connSendFile :: FilePath -> Integer -> Integer -> IO () -> IO () -- ^ offset, length+ , connClose :: IO ()+ , connRecv :: IO B.ByteString+ }++socketConnection :: Socket -> Connection+socketConnection s = Connection+ { connSendMany = Sock.sendMany s+ , connSendAll = Sock.sendAll s+ , connSendFile = error "connSendFile : Cannot send a file here."+ , connClose = sClose s+ , connRecv = Sock.recv s bytesPerRead+ }+++bindPort :: Int -> String -> IO Socket bindPort p s = do let hints = defaultHints { addrFlags = [AI_PASSIVE , AI_NUMERICSERV@@ -113,7 +159,7 @@ addr = if null addrs' then head addrs else head addrs' bracketOnError (Network.Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))- sCloseX+ sClose (\sock -> do setSocketOption sock ReuseAddr 1 bindSocket sock (addrAddress addr)@@ -131,7 +177,7 @@ #if WINDOWS runProxySettings set = withSocketsDo $ do var <- MV.newMVar Nothing- let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sCloseX s >> return Nothing+ let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sClose s >> return Nothing _ <- forkIO $ bracket (bindPort (proxyPort set) (proxyHost set)) (const clean)@@ -143,7 +189,7 @@ runProxySettings set = bracket (bindPort (proxyPort set) (proxyHost set))- sCloseX+ sClose (runSettingsSocket set) #endif @@ -151,239 +197,71 @@ runSettingsSocket :: Settings -> Socket -> IO ()-runSettingsSocket set sock = do+runSettingsSocket set sock =+ runSettingsConnection set getter+ where+ getter = do+ (conn, sa) <- accept sock+ return (socketConnection conn, sa)++runSettingsConnection :: Settings -> IO (Connection, SockAddr) -> IO ()+runSettingsConnection set getConn = do let onE = proxyOnException set- reqRM = proxyRequestModifier set port = proxyPort set tm <- T.initialize $ proxyTimeout set * 1000000- mgr <- HE.newManager+ mgr <- HC.newManager HC.def forever $ do- (conn, sa) <- accept sock+ (conn, addr) <- getConn _ <- forkIO $ do th <- T.registerKillThread tm- serveConnection th tm onE reqRM port conn sa mgr+ serveConnection set th tm onE port conn addr mgr T.cancel th return () -verboseSockets :: Bool-verboseSockets = False--sCloseX :: Socket -> IO ()-sCloseX s = do- when verboseSockets $ putStrLn ("close " ++ show s)- sClose s--shutdownX :: Socket -> ShutdownCmd -> IO ()-shutdownX s ShutdownReceive = do- when verboseSockets $ putStrLn ("shutdown " ++ show s ++ " ShutdownReceive")- shutdown s ShutdownReceive--shutdownX s ShutdownSend = do- when verboseSockets $ putStrLn ("shutdown " ++ show s ++ " ShutdownSend")- shutdown s ShutdownSend--shutdownX s ShutdownBoth = do- when verboseSockets $ putStrLn ("shutdown " ++ show s ++ " ShutdownBoth")- shutdown s ShutdownBoth--mkHeaders :: Monad m- => H.HttpVersion- -> H.Status- -> H.ResponseHeaders- -> E.Enumerator ByteString m b-mkHeaders ver s hrs =- E.enumList 1 [toByteString $ headers ver s hrs False]---serveConnection :: T.Handle+serveConnection :: Settings+ -> T.Handle -> T.Manager -> (SomeException -> IO ())- -> (Request -> IO Request)- -> Port -> Socket -> SockAddr- -> HE.Manager+ -> Port+ -> Connection -> SockAddr+ -> HC.Manager -> IO ()-serveConnection th tm onException requestMod port conn remoteHost' mgr = do- mExtraSocket <- E.run_ (fromClient $$ serveConnection')- `finally` sCloseX conn- case mExtraSocket of- Just (tid, s) -> do- killThread tid- sCloseX s- Nothing -> return ()- `catch` onException+serveConnection settings th tm onException port conn remoteHost' mgr =+ catch+ (finally+ (runResourceT serveConnection')+ (connClose conn))+ onException where- fromClient = enumSocket th bytesPerRead conn-- serveConnection' :: E.Iteratee ByteString IO (Maybe (ThreadId, Socket))+ serveConnection' :: ResourceT IO () serveConnection' = do- req <- parseRequest port remoteHost'+ fromClient <- C.bufferSource $ C.Source $ return $ connSource conn th+ serveConnection'' fromClient++ serveConnection'' fromClient = do+ req <- parseRequest port remoteHost' fromClient --liftIO $ print $ requestHeaders req case req of _ | requestMethod req `elem` [ "GET", "POST" ] ->- liftIO (requestMod req) >>= proxyPlain+ liftIO (proxyRequestModifier settings req)+ >>= proxyPlain th conn mgr+ >>= \keepAlive -> when keepAlive $ serveConnection'' fromClient _ | requestMethod req == "CONNECT" -> case B.split ':' (rawPathInfo req) of- [h, p] -> proxyConnect th tm onException conn h (readDecimal $ B.unpack p) req+ [h, p] -> proxyConnect th tm conn h (readInt p) req+ >>= \keepAlive -> when keepAlive $ serveConnection'' fromClient _ -> failRequest th conn req "Bad request" ("Bad request '" `mappend` rawPathInfo req `mappend` "'.")- _ | otherwise ->+ >>= \keepAlive -> when keepAlive $ serveConnection'' fromClient+ _ -> failRequest th conn req "Unknown request" ("Unknown request '" `mappend` rawPathInfo req `mappend` "'.")-- proxyPlain :: Request -> E.Iteratee ByteString IO (Maybe (ThreadId, Socket))- proxyPlain req = do- let urlStr = "http://" `mappend` serverName req- `mappend` rawPathInfo req- `mappend` rawQueryString req- close =- let hasClose hdrs = (== "close") . CI.mk <$> lookup "connection" hdrs- mClose = hasClose (requestHeaders req)- -- 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- let contentLength = if requestMethod req == "GET"- then 0- else readDecimal . B.unpack . fromMaybe "0" . lookup "content-length" . requestHeaders $ req-- url <-- (\u -> u { HE.method = requestMethod req,- HE.requestHeaders = outHdrs,- HE.rawBody = True,- HE.requestBody = HE.RequestBodyEnum contentLength- $ joinE (enumIteratee contentLength lazyTakeMax)- $ EL.map fromByteString- })- <$> lift (HE.semiParseUrl (B.unpack urlStr))-- close' <- E.run_ $ HE.http url (handleHttpReply close) mgr- if close'- then return Nothing- else serveConnection'- where- handleHttpReply close status hdrs = do- let remoteClose = isNothing ("content-length" `lookup` hdrs)- close' = close || remoteClose- hdrs' = [(n, v) | (n, v) <- hdrs, n `notElem`- ["connection", "proxy-connection"]- ]- ++ [("Connection", if close' then "Close" else "Keep-Alive")]- mkHeaders (httpVersion req) status hdrs' $$ iterSocket th conn close- return remoteClose---- Create an Enumerator from an Iteratee.--- The first parameter is the number of bytes to be pulled from the Iteratee.--- The second is an Iteratee that can pull the data from the source in chunks.--- The return value is an Enumerator that operates inside the Iteratee monad.-enumIteratee :: MonadIO m => Int64- -> (Int -> Iteratee ByteString m ByteString)- -> Enumerator ByteString (Iteratee ByteString m) c-enumIteratee maxlen takeMax = inner 0- where- blockLen = 32768- inner count (Continue k)- | count >= maxlen = k (Chunks [])- | count + blockLen <= maxlen = do- bs <- lift $ takeMax $ fromIntegral blockLen- if B.null bs- then k EOF- else k (Chunks [bs]) >>== inner (count + blength bs)- | otherwise = do- bs <- lift $ takeMax $ fromIntegral (maxlen - count)- if B.null bs- then k EOF- else k (Chunks [bs]) >>== inner (count + blength bs)- inner _ step = returnI step- blength = fromIntegral . B.length---- Take up to maxlen bytes of data as lazily as possible. Avoid splitting and--- joining ByteStrings as much as possible.-lazyTakeMax :: Monad m => Int -> Iteratee ByteString m ByteString-lazyTakeMax maxlen | maxlen <= 0 = return B.empty-lazyTakeMax maxlen = continue step- where- step (Chunks []) = continue step-- step (Chunks (x:xs))- | B.length x < maxlen = yield x (Chunks xs)- | otherwise =- let (start, extra) = B.splitAt maxlen x- in yield start (Chunks (extra:xs))-- step EOF = yield B.empty EOF------------------------------------------------------------------------------------failRequest :: T.Handle -> Socket -> Request -> ByteString -> ByteString -> E.Iteratee ByteString IO (Maybe (ThreadId, Socket))-failRequest th conn req headerMsg bodyMsg = do- EB.isolate 0 =$- E.enumList 1 [bodyMsg] $$- mkHeaders (httpVersion req) status [("Content-Length", B.pack . show . B.length $ bodyMsg)] $$- iterSocket th conn True- return Nothing- where- status = H.status500 { H.statusMessage = headerMsg }--proxyConnect :: T.Handle -> T.Manager -> (SomeException -> IO ()) -> Socket -> ByteString -> Int -> Request -> E.Iteratee ByteString IO (Maybe (ThreadId, Socket))-proxyConnect th tm onException conn host prt req = do- liftIO $ putStrLn $ B.unpack (requestMethod req) ++ " " ++ B.unpack host ++ ":" ++ show prt- mHandles <- liftIO $ do- s <- connectTo (B.unpack host) (PortNumber . fromIntegral $ prt)- let eh = enumSocket th 65536 s- ih = iterSocket th s True- return $ Right (s, eh, ih)- `catch` \(exc :: IOException) ->- return $ Left $ "Unable to connect: " `mappend` B.pack (show exc)- case mHandles of- Right (s, eh, ih) -> do- tid <- liftIO $ forkIO $ do- wrTh <- T.registerKillThread tm- E.run_ (eh $$ mkHeaders (httpVersion req) H.statusOK [] $$ iterSocket wrTh conn True)- `catch` onException- T.cancel wrTh- ih- return (Just (tid, s))- Left errorMsg ->- failRequest th conn req errorMsg ("PROXY FAILURE\r\n" `mappend` errorMsg)--connectTo :: HostName -- Hostname- -> PortID -- Port Identifier- -> IO Socket -- Connected Socket-connectTo hostname (Service serv) = connect' hostname serv-connectTo hostname (PortNumber port) = connect' hostname (show port)-connectTo _ (UnixSocket _) = error "Cannot connect to a UnixSocket"--connect' :: HostName -> ServiceName -> IO Socket-connect' host serv = do- proto <- getProtocolNumber "tcp"- let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]- , addrProtocol = proto- , addrSocketType = Stream }- addrs <- getAddrInfo (Just hints) (Just host) (Just serv)- firstSuccessful $ map tryToConnect addrs- where- tryToConnect addr =- bracketOnError- (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))- sClose -- only done if there's an error- (\sock -> do- connect sock (addrAddress addr)- return sock- )---- Returns the first action from a list which does not throw an exception.--- If all the actions throw exceptions (and the list of actions is not empty),--- the last exception is thrown.-firstSuccessful :: [IO a] -> IO a-firstSuccessful [] = error "firstSuccessful: empty list"-firstSuccessful (p:ps) = catch p $ \e ->- case ps of- [] -> throw (e :: IOException)- _ -> firstSuccessful ps+ >>= \keepAlive -> when keepAlive $ serveConnection'' fromClient -parseRequest :: Port -> SockAddr -> E.Iteratee S.ByteString IO Request-parseRequest port remoteHost' = do- headers' <- takeHeaders- parseRequest' port headers' remoteHost'+parseRequest :: Port -> SockAddr+ -> C.BufferedSource IO S.ByteString+ -> ResourceT IO Request+parseRequest port remoteHost' src = do+ headers' <- src C.$$ takeHeaders+ parseRequest' port headers' remoteHost' src -- FIXME come up with good values here bytesPerRead, maxTotalHeaderLength :: Int@@ -395,7 +273,6 @@ | BadFirstLine String | NonHttp | IncompleteHeaders- | ConnectionClosedByPeer | OverLargeHeader deriving (Show, Typeable, Eq) instance Exception InvalidRequest@@ -404,41 +281,54 @@ parseRequest' :: Port -> [ByteString] -> SockAddr- -> E.Iteratee S.ByteString IO Request-parseRequest' _ [] _ = E.throwError $ NotEnoughLines []-parseRequest' port (firstLine:otherLines) remoteHost' = do+ -> C.BufferedSource IO S.ByteString+ -> ResourceT IO Request+parseRequest' _ [] _ _ = throwIO $ NotEnoughLines []+parseRequest' port (firstLine:otherLines) remoteHost' src = do (method, rpath', gets, httpversion) <- parseFirst firstLine- let (host',rpath) =- if S.null rpath'- then ("","/")- else if "http://" `S.isPrefixOf` rpath'- then S.breakByte 47 $ S.drop 7 rpath' -- '/'- else ("", rpath')+ let (host',rpath)+ | S.null rpath' = ("", "/")+ | "http://" `S.isPrefixOf` rpath' = S.breakByte 47 $ S.drop 7 rpath'+ | otherwise = ("", rpath') let heads = map parseHeaderNoAttr otherLines- let host = case (host', lookup "host" heads) of- ("", Just h) -> h- (h, _) -> h+ let host = fromMaybe host' $ lookup "host" heads+ let len =+ 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 return Request- { requestMethod = method- , httpVersion = httpversion- , pathInfo = H.decodePathSegments rpath- , rawPathInfo = rpath- , rawQueryString = gets- , queryString = H.parseQuery gets- -- NOTE! The meaning of serverName is different from what it is in standard- -- WAI, in the following way:- -- 1. Here it includes the port number. Otherwise there is no way to obtain it.- -- 2. Where 'Host:' is also supplied, we prefer the URI host, since it has the.- -- (WAI gives preference to the 'Host:' header.)- , serverName = host -- serverName'- , serverPort = port- , requestHeaders = heads- , isSecure = False- , remoteHost = remoteHost'- }+ { requestMethod = method+ , httpVersion = httpversion+ , pathInfo = H.decodePathSegments rpath+ , rawPathInfo = rpath+ , rawQueryString = gets+ , queryString = H.parseQuery gets+ , serverName = serverName'+ , serverPort = port+ , requestHeaders = heads+ , isSecure = False+ , remoteHost = remoteHost'+ , requestBody = C.Source $ return rbody+ , vault = mempty+ } ++takeUntil :: Word8 -> ByteString -> ByteString+takeUntil c bs =+ case S.elemIndex c bs of+ Just !idx -> SU.unsafeTake idx bs+ Nothing -> bs+{-# INLINE takeUntil #-}+ parseFirst :: ByteString- -> E.Iteratee S.ByteString IO (ByteString, ByteString, ByteString, H.HttpVersion)+ -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion) parseFirst s = case S.split 32 s of -- ' ' [method, query, http'] -> do@@ -450,8 +340,8 @@ "1.1" -> H.http11 _ -> H.http10 in return (method, rpath, qstring, hv)- else E.throwError NonHttp- _ -> E.throwError $ BadFirstLine $ B.unpack s+ else throwIO NonHttp+ _ -> throwIO $ BadFirstLine $ B.unpack s {-# INLINE parseFirst #-} -- FIXME is this inline necessary? the function is only called from one place and not exported httpBuilder, spaceBuilder, newlineBuilder, transferEncodingBuilder@@ -482,11 +372,97 @@ responseHeaderToBuilder :: Builder -> H.Header -> Builder responseHeaderToBuilder b (x, y) = b- `mappend` copyByteString (CI.original x)- `mappend` colonSpaceBuilder- `mappend` copyByteString y- `mappend` newlineBuilder+ `mappend` copyByteString (CI.original x)+ `mappend` colonSpaceBuilder+ `mappend` copyByteString y+ `mappend` newlineBuilder +checkPersist :: Request -> Bool+checkPersist req+ | ver == H.http11 = checkPersist11 conn+ | otherwise = checkPersist10 conn+ where+ ver = httpVersion req+ conn = lookup "connection" $ requestHeaders req+ checkPersist11 (Just x)+ | CI.foldCase x == "close" = False+ checkPersist11 _ = True+ checkPersist10 (Just x)+ | CI.foldCase x == "keep-alive" = True+ checkPersist10 _ = False++isChunked :: H.HttpVersion -> Bool+isChunked = (==) H.http11++hasBody :: H.Status -> Request -> Bool+hasBody s req = s /= H.Status 204 "" && s /= H.status304 &&+ H.statusCode s >= 200 && requestMethod req /= "HEAD"++sendResponse :: T.Handle+ -> Request -> Connection -> Response -> ResourceT IO Bool+sendResponse th req conn r = sendResponse' r+ where+ version = httpVersion req+ isPersist = checkPersist req+ isChunked' = isChunked version+ needsChunked hs = isChunked' && not (hasLength hs)+ isKeepAlive hs = isPersist && (isChunked' || hasLength hs)+ hasLength hs = isJust $ lookup "content-length" hs++ sendResponse' :: Response -> ResourceT IO Bool+ sendResponse' ResponseFile{} = error "Proxy cannot send a file."++ sendResponse' (ResponseBuilder s hs b)+ | hasBody s req = liftIO $ do+ toByteStringIO (\bs -> do+ connSendAll conn bs+ T.tickle th) body+ return (isKeepAlive hs)+ | otherwise = liftIO $ do+ connSendMany conn+ $ L.toChunks+ $ toLazyByteString+ $ headers' False+ T.tickle th+ return isPersist+ where+ headers' = headers version s hs+ needsChunked' = needsChunked hs+ body = if needsChunked'+ then headers' needsChunked'+ `mappend` chunkedTransferEncoding b+ `mappend` chunkedTransferTerminator+ else headers' False `mappend` b++ sendResponse' (ResponseSource s hs body) =+ response+ where+ 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)+ response+ | not (hasBody s req) = liftIO $ do+ connSendMany conn+ $ L.toChunks $ toLazyByteString+ $ headers' False+ T.tickle th+ return (checkPersist req)+ | otherwise = do+ let src =+ CL.sourceList [headers' needsChunked'] `mappend`+ (if needsChunked' then body C.$= chunk else body)+ src C.$$ builderToByteString C.=$ connSink conn th+ return $ isKeepAlive hs+ needsChunked' = needsChunked hs+ chunk :: C.Conduit Builder IO Builder+ chunk = C.Conduit $ return C.PreparedConduit+ { C.conduitPush = push+ , C.conduitClose = close+ }++ push x = return $ C.Producing [chunkedTransferEncoding x]+ close = return [chunkedTransferTerminator]+ parseHeaderNoAttr :: ByteString -> H.Header parseHeaderNoAttr s = let (k, rest) = S.breakByte 58 s -- ':'@@ -497,52 +473,40 @@ else rest in (CI.mk k, rest') -enumSocket :: T.Handle -> Int -> Socket -> E.Enumerator ByteString IO a-enumSocket th len sock =- inner- where- inner (E.Continue k) = do- bs <- liftIO $ Sock.recv sock len- liftIO $ T.tickle th+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 do- liftIO $- shutdownX sock ShutdownReceive- `catch` \(exc :: IOException) ->- putStrLn $ "couldn't shutdown read side of " ++ show sock ++ ": " ++ show exc- E.continue k- else k (E.Chunks [bs]) >>== inner- inner step = E.returnI step------- The functions below are not warp-specific and could be split out into a---separate package.+ then return C.Closed+ else do+ when (S.length bs >= 2048) $ liftIO $ T.tickle th+ return (C.Open bs)+ , C.sourceClose = return ()+ } -iterSocket :: MonadIO m- => T.Handle- -> Socket- -> Bool -- ^ To close- -> E.Iteratee B.ByteString m ()-iterSocket th sock toClose =- E.continue step+-- | 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+ } where+ close = liftIO (T.resume th)+ push x = do+ liftIO $ T.resume th+ liftIO $ send x+ liftIO $ T.pause th+ return C.Processing -- We pause timeouts before passing control back to user code. This ensures- -- that a timeout will only ever be executed when the proxy is in control. We+ -- 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 -- so that we can kill idle connections.- step E.EOF = do- liftIO $ T.resume th- when toClose $- liftIO $- shutdownX sock ShutdownSend- `catch` \(exc :: IOException) ->- putStrLn $ "couldn't shutdown send side of " ++ show sock ++ ": " ++ show exc- E.yield () E.EOF- step (E.Chunks []) = E.continue step- step (E.Chunks xs) = do- liftIO $ T.resume th- liftIO $ Sock.sendMany sock xs- liftIO $ T.pause th- E.continue step +------ The functions below are not warp-specific and could be split out into a+--separate package.++ -- | Various proxy server settings. This is purposely kept as an abstract data -- type so that new settings can be added without breaking backwards -- compatibility. In order to create a 'Settings' value, use 'defaultSettings'@@ -578,66 +542,60 @@ go' (Just ThreadKilled) = False go' _ = True -takeHeaders :: E.Iteratee ByteString IO [ByteString]-takeHeaders = do- !x <- forceHead ConnectionClosedByPeer- takeHeaders' 0 id id x--{-# INLINE takeHeaders #-}+type BSEndo = ByteString -> ByteString+type BSEndoList = [ByteString] -> [ByteString] -takeHeaders' :: Int- -> ([ByteString] -> [ByteString])- -> ([ByteString] -> [ByteString])- -> ByteString- -> E.Iteratee S.ByteString IO [ByteString]-takeHeaders' !len _ _ _ | len > maxTotalHeaderLength = E.throwError OverLargeHeader-takeHeaders' !len !lines !prepend !bs = do- let !bsLen = {-# SCC "takeHeaders'.bsLen" #-} S.length bs- !mnl = {-# SCC "takeHeaders'.mnl" #-} S.elemIndex 10 bs- case mnl of- -- no newline. prepend entire bs to next line- !Nothing -> {-# SCC "takeHeaders'.noNewline" #-} do- let !len' = len + bsLen- !more <- forceHead IncompleteHeaders- takeHeaders' len' lines (prepend . (:) bs) more- Just !nl -> {-# SCC "takeHeaders'.newline" #-} do- let !end = nl- !start = nl + 1- !line = {-# SCC "takeHeaders'.line" #-}- if end > 0- -- line data included in this chunk- then S.concat $! prepend [SU.unsafeTake (checkCR bs end) bs]- --then S.concat $! prepend [SU.unsafeTake (end-1) bs]- -- no line data in this chunk (all in prepend, or empty line)- else S.concat $! prepend []- if S.null line- -- no more headers- then {-# SCC "takeHeaders'.noMoreHeaders" #-} do- let !lines' = {-# SCC "takeHeaders'.noMoreHeaders.lines'" #-} lines []- if start < bsLen- then {-# SCC "takeHeaders'.noMoreHeaders.yield" #-} do- let !rest = {-# SCC "takeHeaders'.noMoreHeaders.yield.rest" #-} SU.unsafeDrop start bs- E.yield lines' $! E.Chunks [rest]- else return lines'+data THStatus = THStatus+ {-# UNPACK #-} !Int -- running total byte count+ BSEndoList -- previously parsed lines+ BSEndo -- bytestrings to be prepended - -- more headers- else {-# SCC "takeHeaders'.moreHeaders" #-} do- let !len' = len + start- !lines' = {-# SCC "takeHeaders.lines'" #-} lines . (:) line- !more <- {-# SCC "takeHeaders'.more" #-}- if start < bsLen- then return $! SU.unsafeDrop start bs- else forceHead IncompleteHeaders- {-# SCC "takeHeaders'.takeMore" #-} takeHeaders' len' lines' id more-{-# INLINE takeHeaders' #-}+takeHeaders :: C.Sink ByteString IO [ByteString]+takeHeaders =+ C.sinkState (THStatus 0 id id) takeHeadersPush close+ where+ close _ = throwIO IncompleteHeaders+{-# INLINE takeHeaders #-} -forceHead :: InvalidRequest -> E.Iteratee ByteString IO ByteString-forceHead err = do- !mx <- EL.head- case mx of- !Nothing -> E.throwError err- Just !x -> return x-{-# INLINE forceHead #-}+takeHeadersPush :: THStatus+ -> ByteString+ -> ResourceT IO (THStatus, C.SinkResult ByteString [ByteString])+takeHeadersPush (THStatus len _ _ ) _+ | len > maxTotalHeaderLength = throwIO OverLargeHeader+takeHeadersPush (THStatus len lines prepend) bs =+ case mnl of+ -- no newline. prepend entire bs to next line+ Nothing -> do+ let len' = len + bsLen+ return (THStatus len' lines (prepend . S.append bs), C.Processing)+ Just nl -> do+ let end = nl+ start = nl + 1+ line = prepend (if end > 0+ then SU.unsafeTake (checkCR bs end) bs+ else S.empty)+ if S.null line+ -- no more headers+ then do+ let lines' = lines []+ 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')+ -- more headers+ else do+ let len' = len + start+ lines' = lines . (:) line+ if start < bsLen+ then do+ let more = SU.unsafeDrop start bs+ takeHeadersPush (THStatus len' lines' id) more+ else return (THStatus len' lines' id, C.Processing)+ where+ bsLen = S.length bs+ mnl = S.elemIndex 10 bs+{-# INLINE takeHeadersPush #-} checkCR :: ByteString -> Int -> Int checkCR bs pos =@@ -647,6 +605,11 @@ 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@@ -657,10 +620,120 @@ server = (key, ver) servers svr = (key, S.concat [svr, " ", ver]) +-------------------------------------------------------------------------------- -readDecimal :: Num a => String -> a-readDecimal s =- case readDec s of- [] -> 0- (x, _):_ -> x+proxyPlain :: T.Handle -> Connection -> HC.Manager -> Request -> ResourceT IO Bool+proxyPlain th conn mgr req = do+ let urlStr = "http://" `mappend` serverName req+ `mappend` rawPathInfo req+ `mappend` rawQueryString req+ close =+ let hasClose hdrs = (== "close") . CI.mk <$> lookup "connection" hdrs+ mClose = hasClose (requestHeaders req)+ -- 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+ 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+ $ fmap copyByteString+ $ requestBody req+ })+ <$> lift (HC.parseUrl (B.unpack urlStr))++ HC.Response sc rh bodySource <- HC.http url mgr+ close' <- handleHttpReply close sc rh+ bodySource C.$$ connSink conn th+ return $ not close'+ where+ handleHttpReply close status hdrs = do+ let remoteClose = isNothing ("content-length" `lookup` hdrs)+ close' = close || remoteClose+ hdrs' = [(n, v) | (n, v) <- hdrs, n `notElem`+ ["connection", "proxy-connection"]+ ]+ ++ [("Connection", if close' then "Close" else "Keep-Alive")]+ liftIO $ connSendMany conn $ L.toChunks $ toLazyByteString $+ headers (httpVersion req) status hdrs' False+ return remoteClose++failRequest :: T.Handle -> Connection -> Request -> ByteString -> ByteString -> ResourceT IO Bool+failRequest th conn req headerMsg bodyMsg =+ sendResponse th req conn $ ResponseBuilder status hdrs $ copyByteString bodyMsg+ where+ hdrs = [("Content-Length", B.pack . show . B.length $ bodyMsg)]+ status = H.status500 { H.statusMessage = headerMsg }+++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+ eConn <- liftIO $ do+ usock <- socketConnection `fmap` connectTo (B.unpack host) (PortNumber . fromIntegral $ prt)+ return $ Right usock+ `catch` \(exc :: IOException) ->+ 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+ liftIO $+ connSendMany conn $ L.toChunks $ toLazyByteString+ $ headers (httpVersion req) H.statusOK [] False+ void $ with (forkIO $ do+ wrTh <- T.registerKillThread tm+ runResourceT (fromUpstream C.$$ connSink conn wrTh)+ T.cancel wrTh+ ) killThread+ fromClient <- C.bufferSource $ C.Source $ return $ connSource conn th+ fromClient C.$$ connSink uconn th+ return False+ Left errorMsg ->+ failRequest th conn req errorMsg ("PROXY FAILURE\r\n" `mappend` errorMsg)+++connectTo :: HostName -- Hostname+ -> PortID -- Port Identifier+ -> IO Socket -- Connected Socket+connectTo hostname (Service serv) = connect' hostname serv+connectTo hostname (PortNumber port) = connect' hostname (show port)+connectTo _ (UnixSocket _) = error "Cannot connect to a UnixSocket"++connect' :: HostName -> ServiceName -> IO Socket+connect' host serv = do+ proto <- getProtocolNumber "tcp"+ let hints = defaultHints { addrFlags = [AI_ADDRCONFIG]+ , addrProtocol = proto+ , addrSocketType = Stream }+ addrs <- getAddrInfo (Just hints) (Just host) (Just serv)+ firstSuccessful $ map tryToConnect addrs+ where+ tryToConnect addr =+ bracketOnError+ (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))+ sClose -- only done if there's an error+ (\sock -> do+ connect sock (addrAddress addr)+ return sock+ )++-- Returns the first action from a list which does not throw an exception.+-- If all the actions throw exceptions (and the list of actions is not empty),+-- the last exception is thrown.+firstSuccessful :: [IO a] -> IO a+firstSuccessful [] = error "firstSuccessful: empty list"+firstSuccessful (p:ps) = catch p $ \e ->+ case ps of+ [] -> throw (e :: IOException)+ _ -> firstSuccessful ps+++
+ Network/HTTP/Proxy/ReadInt.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings, MagicHash, BangPatterns #-}++-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- 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"#+
http-proxy.cabal view
@@ -1,13 +1,14 @@ Name: http-proxy-Version: 0.0.5+Version: 0.0.6 License: BSD3 License-file: LICENSE Author: Michael Snoyman, Stephen Blackheath, Erik de Castro Lopo Maintainer: erikd@mega-nerd.com Homepage: https://github.com/erikd/http-proxy+Bug-reports: https://github.com/erikd/http-proxy/issues Category: Web Build-Type: Simple-Cabal-Version: >=1.6+Cabal-Version: >=1.8 Stability: Experimental Synopsis: A library for writing HTTP and HTTPS proxies@@ -15,7 +16,7 @@ Description: http-proxy is a library for writing HTTP and HTTPS proxies. .- Use of the enumerator library provides file streaming via the proxy in both+ Use of the Conduit library provides file streaming via the proxy in both directions. Memory usage of the proxy scales linearly with the number of simultaneous connections and is independent of the size of the files being uploaded or downloaded.@@ -30,13 +31,16 @@ Library Build-Depends: base >= 3 && < 5 , bytestring >= 0.9.1.4 && < 0.10- , wai >= 0.4 && < 0.5- , enumerator >= 0.4.8 && < 0.5- , http-enumerator >= 0.7.2.2 && < 0.8+ , 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.2+ , case-insensitive >= 0.4 && < 0.5+ , lifted-base >= 0.1 && < 0.2+ , blaze-builder-conduit >= 0.0 && < 0.1+ , ghc-prim if flag(network-bytestring) build-depends: network >= 2.2.1.5 && < 2.2.3 , network-bytestring >= 0.1.3 && < 0.1.4@@ -44,6 +48,7 @@ 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 if os(windows)