http-proxy 0.0.12 → 0.1.0.1
raw patch · 11 files changed
+1047/−934 lines, 11 filesdep +QuickCheckdep +asyncdep +conduit-extradep −base64-bytestringdep −blaze-builder-conduitdep −ghc-primdep ~basedep ~blaze-builderdep ~bytestring
Dependencies added: QuickCheck, async, conduit-extra, connection, hspec, http-client, mtl, random, text, vault, wai-conduit, warp, warp-tls
Dependencies removed: base64-bytestring, blaze-builder-conduit, ghc-prim, lifted-base, network-bytestring
Dependency ranges changed: base, blaze-builder, bytestring, bytestring-lexing, case-insensitive, conduit, http-conduit, http-types, network, resourcet, tls, transformers, wai
Files
- Network/HTTP/Proxy.hs +128/−830
- Network/HTTP/Proxy/Request.hs +62/−0
- Network/HTTP/Proxy/Timeout.hs +0/−76
- Test/Gen.hs +99/−0
- Test/Request.hs +78/−0
- Test/ServerDef.hs +48/−0
- Test/TestServer.hs +106/−0
- Test/Util.hs +232/−0
- Test/Wai.hs +29/−0
- Test/testsuite.hs +201/−0
- http-proxy.cabal +64/−28
Network/HTTP/Proxy.hs view
@@ -1,23 +1,18 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------- Copyright : Michael Snoyman, Stephen Blackheath, Erik de Castro Lopo--- Maintainer : Erik de Castro Lopo <erikd@mega-nerd.com>--- License : BSD3+{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings #-}+--------------------------------------------------------------------------------+-- Copyright : Michael Snoyman, Erik de Castro Lopo+-- Maintainer : Erik de Castro Lopo <erikd@mega-nerd.com>+-- License : BSD3 -- -- History:--- This code originated in Michael Snoyman's Warp package when Warp was based--- on the Data.Enumerator library. That code was modified by Stephen--- Blackheath to turn it into a HTTP/HTTPS 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.+-- Previous versions of http-proxy included a modified version of the Warp+-- web server. Thankfully, Michael Snoyman made changes to Warp and Wai to+-- allow both a HTTP and a HTTPS proxy to be implemented solely as a Wai+-- Application.+-- This version of http-proxy is based on a piece of code Michael Snoyman+-- published as a gist on github.com. ------------------------------------------------------------+-------------------------------------------------------------------------------- -- | This module contains a simple HTTP and HTTPS proxy. In the most basic -- setup, the caller specifies a port and runs it as follows:@@ -31,80 +26,40 @@ -- module Network.HTTP.Proxy- ( runProxy- , runProxySettings-+ ( Port+ , Request (..) , Settings (..)- , defaultSettings , UpstreamProxy (..)- , Request (..)- )-where -import Prelude hiding (catch, lines)--import Data.ByteString (ByteString)-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- ( accept, Family (..)- , SocketType (Stream), listen, bindSocket, setSocketOption, maxListenQueue- , SockAddr, SocketOption (ReuseAddr)- , AddrInfo(..), AddrInfoFlag(..), defaultHints, getAddrInfo- , Socket, sClose, HostName, ServiceName, socket, connect- )-import Network.BSD ( getProtocolNumber )-import Network.Wai-import qualified Network.Socket-import qualified Network.Socket.ByteString as Sock-import Control.Applicative-import Control.Exception- ( bracket, finally, Exception, SomeException, catch- , fromException, AsyncException (ThreadKilled)- , bracketOnError, IOException, throw+ , runProxy+ , runProxySettings+ , runProxySettingsSocket+ , defaultProxySettings )-import Control.Concurrent (forkIO, killThread)-import Data.Maybe (fromMaybe, isJust, isNothing)-import qualified Network.HTTP.Conduit as HC--import Data.Typeable (Typeable)+ where -import Control.Monad.Trans.Resource (ResourceT, runResourceT, allocate)-import qualified Data.Conduit as C-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, flush)-import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)-import Data.Monoid (mappend, mempty)+import Blaze.ByteString.Builder (fromByteString)+import Control.Concurrent.Async (race_)+import Control.Exception -- (SomeException, catch, toException)+import Data.ByteString.Char8 (ByteString)+import Data.Conduit (Flush (..), Sink, Source, ($$), mapOutput, yield)+import Data.Conduit.Network+import Data.Monoid+import Network.Socket+import Network.Wai.Conduit hiding (Request, requestMethod) -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, void)-import qualified Network.HTTP.Types as H+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.CaseInsensitive as CI-import System.IO (hPutStrLn, stderr)-import qualified Data.IORef as I-import Data.String (IsString (..))-import qualified Data.ByteString.Lex.Integral as LI-import Network.TLS (TLSCertificateUsage (..))-import qualified Data.ByteString.Base64 as B64+import qualified Data.Conduit.Network as NC+import qualified Network.HTTP.Client as HC+import qualified Network.HTTP.Conduit as HC+import qualified Network.HTTP.Client.Conduit as HCC+import qualified Network.HTTP.Types as HT+import qualified Network.Wai as Wai+import qualified Network.Wai.Handler.Warp as Warp -#if WINDOWS-import Control.Concurrent (threadDelay)-import qualified Control.Concurrent.MVar as MV-import Network.Socket (withSocketsDo)-#endif+import Network.HTTP.Proxy.Request #if 0 import Data.Version (showVersion)@@ -114,549 +69,45 @@ 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 -> HostPreference -> IO Socket-bindPort p s = do- let hints = defaultHints { addrFlags = [AI_PASSIVE- , AI_NUMERICSERV- , AI_NUMERICHOST]- , addrSocketType = Stream }- 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 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- (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- 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'.+-- 'runProxySettings' with 'defaultProxySettings'. runProxy :: Port -> IO ()-runProxy p = runProxySettings defaultSettings { proxyPort = p }+runProxy port = runProxySettings $ defaultProxySettings { proxyPort = port } -- | Run a HTTP and HTTPS proxy server with the specified settings. runProxySettings :: Settings -> IO ()-#if WINDOWS-runProxySettings set = withSocketsDo $ do- var <- MV.newMVar Nothing- let clean = MV.modifyMVar_ var $ \s -> maybe (return ()) sClose s >> return Nothing- _ <- forkIO $ bracket- (bindPort (proxyPort set) (proxyHost set))- (const clean)- (\s -> do- MV.modifyMVar_ var (\_ -> return $ Just s)- runSettingsSocket set s)- forever (threadDelay maxBound) `finally` clean-#else-runProxySettings set =- bracket- (bindPort (proxyPort set) (proxyHost set))- sClose- (runSettingsSocket set)-#endif--type Port = Int---runSettingsSocket :: Settings -> Socket -> IO ()-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- port = proxyPort set- tm <- T.initialize $ proxyTimeout set * 1000000- 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 ()---- | Contains a @Source@ and a byte count that is still to be read in.-newtype IsolatedBSSource = IsolatedBSSource (I.IORef (Int, C.Source (ResourceT IO) ByteString))---- | Given an @IsolatedBSSource@ provide a @Source@ that only allows up to the--- specified number of bytes to be passed downstream. All leftovers should be--- retained within the @Source@. If there are not enough bytes available,--- throws a @ConnectionClosedByPeer@ exception.-ibsIsolate :: IsolatedBSSource -> C.Source (ResourceT IO) ByteString-ibsIsolate ibs@(IsolatedBSSource ref) =- C.PipeM pull (return ())- where- pull = do- (count, src) <- liftIO $ I.readIORef ref- if count == 0- -- No more bytes wanted downstream, so we're done.- then return $ C.Done Nothing ()- else do- -- Get the next chunk (if available) and the updated source- (src', mbs) <- src C.$$+ CL.head-- -- If no chunk available, then there aren't enough bytes in the- -- stream. Throw a ConnectionClosedByPeer- bs <- maybe (liftIO $ throwIO ConnectionClosedByPeer) return mbs-- let -- How many of the bytes in this chunk to send downstream- toSend = min count (S.length bs)- -- How many bytes will still remain to be sent downstream- count' = count - toSend- case () of- ()- -- The expected count is greater than the size of the- -- chunk we just read. Send the entire chunk- -- downstream, and then loop on this function for the- -- next chunk.- | count' > 0 -> do- liftIO $ I.writeIORef ref (count', src')- return $ C.HaveOutput (ibsIsolate ibs) (return ()) bs-- -- The expected count is the total size of the chunk we- -- just read. Send this chunk downstream, and then- -- terminate the stream.- | count == S.length bs -> do- liftIO $ I.writeIORef ref (count', src')- return $ C.HaveOutput (C.Done Nothing ()) (return ()) bs-- -- Some of the bytes in this chunk should not be sent- -- downstream. Split up the chunk into the sent and- -- not-sent parts, add the not-sent parts onto the new- -- source, and send the rest of the chunk downstream.- | otherwise -> do- let (x, y) = S.splitAt toSend bs- liftIO $ I.writeIORef ref (count', C.HaveOutput src' (return ()) y)- return $ C.HaveOutput (C.Done Nothing ()) (return ()) x---- | Extract the underlying @Source@ from an @IsolatedBSSource@, which will not--- perform any more isolation.--serveConnection :: Settings- -> T.Handle- -> T.Manager- -> (SomeException -> IO ())- -> Port- -> Connection -> SockAddr- -> HC.Manager- -> IO ()-serveConnection settings th tm onException port conn remoteHost' mgr =- catch- (finally- (runResourceT serveConnection')- (connClose conn))- onException- where- serveConnection' :: ResourceT IO ()- serveConnection' = do- let fromClient = connSource conn th- serveConnection'' fromClient-- serveConnection'' :: C.Source (ResourceT IO) ByteString -> ResourceT IO ()- serveConnection'' fromClient = do- (req, _ibs) <- parseRequest conn port remoteHost' fromClient- case req of- _ | requestMethod req `elem` [ "GET", "POST" ] ->- 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, LI.readDecimal_ p)- _ -> (serverName req, serverPort req)- modReq <- liftIO $ proxyRequestModifier settings req { serverName = hs, serverPort = ps }- proxyPlain (proxyUpstream settings) 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 (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- _ ->- failRequest th conn req "Unknown request" ("Unknown request '" `mappend` rawPathInfo req `mappend` "'.")- >>= \keepAlive -> when keepAlive $ serveConnection'' fromClient---parseRequest :: Connection -> Port -> SockAddr- -> C.Source (ResourceT IO) S.ByteString- -> ResourceT IO (Request, IsolatedBSSource)-parseRequest conn port remoteHost' src1 = do- (src2, headers') <- src1 C.$$+ takeHeaders- parseRequest' conn port headers' remoteHost' src2---- FIXME come up with good values here-bytesPerRead, maxTotalHeaderLength :: Int-bytesPerRead = 4096-maxTotalHeaderLength = 50 * 1024--data InvalidRequest =- NotEnoughLines [String]- | BadFirstLine String- | NonHttp- | IncompleteHeaders- | ConnectionClosedByPeer- | OverLargeHeader- 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' :: Connection- -> Port- -> [ByteString]- -> SockAddr- -> C.Source (ResourceT IO) S.ByteString -- FIXME was buffered- -> ResourceT IO (Request, IsolatedBSSource)-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')- heads <- liftIO- $ handleExpect conn httpversion id- (map parseHeaderNoAttr otherLines)- let host = fromMaybe host' $ lookup "host" heads- let len0 =- case lookup "content-length" heads of- Nothing -> 0- Just bs -> LI.readDecimal_ bs- let serverName' = takeUntil 58 host -- ':'- (rbody, ibs) <- liftIO $ do- ibs <- fmap IsolatedBSSource $ I.newIORef (len0, src)- return (ibsIsolate ibs, ibs)- return (Request- { 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 = rbody- , vault = mempty- }, ibs)---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- -> ResourceT IO (ByteString, ByteString, ByteString, H.HttpVersion)-parseFirst s =- case S.split 32 s of -- ' '- [method, query, http'] -> do- let (hfirst, hsecond) = B.splitAt 5 http'- if hfirst == "HTTP/"- then let (rpath, qstring) = S.breakByte 63 query -- '?'- hv =- case hsecond of- "1.1" -> H.http11- _ -> H.http10- in return (method, rpath, qstring, hv)- 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- , colonSpaceBuilder :: Builder-httpBuilder = copyByteString "HTTP/"-spaceBuilder = fromChar ' '-newlineBuilder = copyByteString "\r\n"-transferEncodingBuilder = copyByteString "Transfer-Encoding: chunked\r\n\r\n"-colonSpaceBuilder = copyByteString ": "--headers :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> Builder-headers !httpversion !status !responseHeaders !isChunked' = {-# SCC "headers" #-}- let !start = httpBuilder- `mappend` copyByteString- (case httpversion of- H.HttpVersion 1 1 -> "1.1"- _ -> "1.0")- `mappend` spaceBuilder- `mappend` fromShow (H.statusCode status)- `mappend` spaceBuilder- `mappend` copyByteString (H.statusMessage status)- `mappend` newlineBuilder- !start' = foldl' responseHeaderToBuilder start (serverHeader responseHeaders)- !end = if isChunked'- then transferEncodingBuilder- else newlineBuilder- in start' `mappend` end--responseHeaderToBuilder :: Builder -> H.Header -> Builder-responseHeaderToBuilder b (x, y) = b- `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 = sendResponse'- 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- sendHeader = connSendMany conn . L.toChunks . toLazyByteString-- 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 = sendOtherwise headers'- 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 bodyFlush)- | hasBody s req = 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- | otherwise = sendOtherwise headers'- where- body = fmap2 (\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)- needsChunked' = needsChunked hs- chunk :: C.Conduit Builder (ResourceT IO) Builder- chunk = C.NeedInput push close- push x = C.HaveOutput chunk (return ()) (chunkedTransferEncoding x)- close = C.HaveOutput (C.Done Nothing ()) (return ()) chunkedTransferTerminator-- sendOtherwise hdrs = liftIO $ do- sendHeader $ hdrs False- T.tickle th- return isPersist---fmap2 :: Functor m => (o1 -> o2) -> C.Pipe i o1 m r -> C.Pipe i o2 m r-fmap2 f (C.HaveOutput p c o) = C.HaveOutput (fmap2 f p) c (f o)-fmap2 f (C.NeedInput p c) = C.NeedInput (fmap2 f . p) (fmap2 f c)-fmap2 f (C.PipeM mp c) = C.PipeM (fmap (fmap2 f) mp) c-fmap2 _ (C.Done i x) = C.Done i x--parseHeaderNoAttr :: ByteString -> H.Header-parseHeaderNoAttr s =- let (k, rest) = S.breakByte 58 s -- ':'- restLen = S.length rest- -- FIXME check for colon without following space?- rest' = if restLen > 1 && SU.unsafeTake 2 rest == ": "- then SU.unsafeDrop 2 rest- else rest- in (CI.mk k, rest')--connSource :: Connection -> T.Handle -> C.Source (ResourceT IO) ByteString-connSource Connection { connRecv = recv } th =- src- where- src = C.PipeM (do- bs <- liftIO recv- if S.null bs- then return $ C.Done Nothing ()- else do- when (S.length bs >= 2048) $ liftIO $ T.tickle th- return (C.HaveOutput src (return ()) bs))- (return ())---- | Use 'connSendAll' to send this data while respecting timeout rules.-connSink :: Connection -> T.Handle -> C.Sink B.ByteString (ResourceT IO) ()-connSink Connection { connSendAll = send } th =- sink- where- sink = C.NeedInput push close- close = liftIO (T.resume th)- push x = C.PipeM (liftIO $ do- T.resume th- send x- T.pause th- return sink) (liftIO $ T.resume th)- -- 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- -- so that we can kill idle connections.-------- The functions below are not warp-specific and could be split out into a---separate package.+runProxySettings set = do+ mgr <- HC.newManager HC.tlsManagerSettings+ Warp.runSettings (warpSettings set) $ proxyApp set mgr +-- | Run a HTTP and HTTPS proxy server with the specified settings but provide+-- it with a Socket to accept connections on. The Socket should have already+-- have had `bind` and `listen` called on it so that the proxy can simple+-- `accept` connections.+runProxySettingsSocket :: Settings -> Socket -> IO ()+runProxySettingsSocket set sock = do+ port <- socketPort sock+ mgr <- HC.newManager HC.tlsManagerSettings+ Warp.runSettingsSocket (warpSettings set) sock+ $ proxyApp set { proxyPort = fromIntegral port } mgr -- | 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'+-- compatibility. In order to create a 'Settings' value, use 'defaultProxySettings' -- and record syntax to modify individual records. For example: ----- > defaultSettings { proxyPort = 3128 }+-- > defaultProxySettings { proxyPort = 3128 } data Settings = Settings { proxyPort :: Int -- ^ Port to listen on. Default value: 3100 , 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.+ , proxyOnException :: SomeException -> Wai.Response -- ^ 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'.+ , proxyRequestModifier :: Request -> IO (Either Response Request) -- ^ A function that allows the the request to be modified before being run. Default: 'return . Right'. , proxyLogger :: ByteString -> IO () -- ^ A function for logging proxy internal state. Default: 'return ()'. , proxyUpstream :: Maybe UpstreamProxy -- ^ Optional upstream proxy. } --- | 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- -- | A http-proxy can be configured to use and upstream proxy by providing the -- proxy name, the port it listens to and an option username and password for -- proxy authorisation.@@ -666,243 +117,90 @@ , upstreamAuth :: Maybe (ByteString, ByteString) -- ^ Optional username and password to use with upstream proxy. } ++warpSettings :: Settings -> Warp.Settings+warpSettings pset = Warp.setPort (proxyPort pset)+ . Warp.setHost (proxyHost pset)+ . Warp.setTimeout (proxyTimeout pset)+ . Warp.setOnException (\ _ _ -> return ())+ . Warp.setOnExceptionResponse defaultExceptionResponse+ $ Warp.setNoParsePath True Warp.defaultSettings+ -- | The default settings for the Proxy server. See the individual settings for -- the default value.-defaultSettings :: Settings-defaultSettings = Settings+defaultProxySettings :: Settings+defaultProxySettings = Settings { proxyPort = 3100 , proxyHost = "*"- , proxyOnException = \e ->- case fromException e of- Just x -> go x- Nothing ->- when (go' $ fromException e)- $ hPutStrLn stderr $ "ProxyEx: " ++ show e+ , proxyOnException = defaultExceptionResponse , proxyTimeout = 30- , proxyRequestModifier = return . id- , proxyLogger = \ _ -> return ()+ , proxyRequestModifier = return . Right+ , proxyLogger = const $ return () , proxyUpstream = Nothing }- where- go :: InvalidRequest -> IO ()- go _ = return ()- go' (Just ThreadKilled) = False- go' _ = True -type BSEndo = ByteString -> ByteString-type BSEndoList = [ByteString] -> [ByteString]--data THStatus = THStatus- {-# UNPACK #-} !Int -- running total byte count- BSEndoList -- previously parsed lines- BSEndo -- bytestrings to be prepended--takeHeaders :: C.Sink ByteString (ResourceT IO) [ByteString]-takeHeaders =- C.NeedInput (push (THStatus 0 id id)) close- where- close = throwIO IncompleteHeaders+defaultExceptionResponse :: SomeException -> Wai.Response+defaultExceptionResponse e =+ Wai.responseLBS HT.internalServerError500+ [ (HT.hContentType, "text/plain; charset=utf-8") ]+ $ LBS.fromChunks [BS.pack $ show e] - push (THStatus len lines prepend) bs- -- Too many bytes- | len > maxTotalHeaderLength = throwIO OverLargeHeader- | otherwise =- case mnl of- -- No newline find in this chunk. Add it to the prepend,- -- update the length, and continue processing.- Nothing ->- let len' = len + bsLen- prepend' = prepend . S.append bs- status = THStatus len' lines prepend'- in C.NeedInput (push status) close- -- Found a newline at position end.- Just end ->- let start = end + 1 -- start of next chunk- line- -- There were some bytes before the newline, get them- | end > 0 = prepend $ SU.unsafeTake (checkCR bs end) bs- -- No bytes before the newline- | otherwise = prepend S.empty- in if S.null line- -- no more headers- then- let lines' = lines []- -- leftover- rest = if start < bsLen- then Just (SU.unsafeDrop start bs)- else Nothing- in C.Done rest lines'- -- more headers- else- let len' = len + start- lines' = lines . (line:)- status = THStatus len' lines' id- in if start < bsLen- -- more bytes in this chunk, push again- then let bs' = SU.unsafeDrop start bs- in push status bs'- -- no more bytes in this chunk, ask for more- else C.NeedInput (push status) close- where- bsLen = S.length bs- mnl = S.elemIndex 10 bs-{-# INLINE takeHeaders #-}+-- ----------------------------------------------------------------------------- -checkCR :: ByteString -> Int -> Int-checkCR bs pos =- let !p = pos - 1- in if '\r' == B.index bs p- then p- else pos-{-# INLINE checkCR #-}+proxyApp :: Settings -> HC.Manager -> Wai.Request -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+proxyApp settings mgr wreq respond = do+ mwreq <- proxyRequestModifier settings $ proxyRequest wreq+ either respond (doUpstreamRequest settings mgr respond . waiRequest wreq) mwreq -serverHeader :: H.RequestHeaders -> H.RequestHeaders-serverHeader hdrs = case lookup key hdrs of- Nothing -> server : hdrs- Just svr -> servers svr : delete (key,svr) hdrs- where- key = "Via"- ver = B.pack "Proxy/0.0"- server = (key, ver)- servers svr = (key, S.concat [svr, " ", ver])------------------------------------------------------------------------------------proxyPlain :: Maybe UpstreamProxy -> T.Handle -> Connection -> HC.Manager -> Request -> ResourceT IO Bool-proxyPlain upstream th conn mgr req = do- let portStr = case (serverPort req, isSecure req) of- (80, False) -> mempty- (443, True) -> mempty- (n, _) -> fromString (':' : show n)- urlStr = (if isSecure req then "https://" else "http://")- `mappend` serverName req- `mappend` portStr- `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 `notElem` [ "Host", "Accept-Encoding", "Content-Length" ]]- -- liftIO $ putStrLn $ B.unpack (requestMethod req) ++ " " ++ B.unpack urlStr- let contentLength = if requestMethod req == "GET"- then 0- else LI.readDecimal_ . fromMaybe "0" . lookup "content-length" . requestHeaders $ req-- let (proxy, pauth) = case upstream of- Nothing -> (Nothing, [])- Just (UpstreamProxy ph pp Nothing) ->- ( Just (HC.Proxy ph pp), [])- Just (UpstreamProxy ph pp (Just (u, p))) ->- ( Just (HC.Proxy ph pp)- , [ ( "Proxy-Authorization"- , B.append "Basic " (B64.encode $ B.concat [ u, ":", p ])- )- ] )-- url <-- (\u -> u { HC.method = requestMethod req- , HC.requestHeaders = pauth ++ outHdrs- , HC.rawBody = True- , HC.secure = isSecure req- , HC.requestBody = HC.RequestBodySource contentLength- $ fmap2 copyByteString- $ requestBody req- , HC.proxy = proxy- -- 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 hver rh bodySource <- HC.http url mgr- close' <- handleHttpReply close sc hver rh- bodySource C.$$ connSink conn th- return $ not close'+doUpstreamRequest :: Settings -> HC.Manager -> (Wai.Response -> IO Wai.ResponseReceived) -> Wai.Request -> IO Wai.ResponseReceived+doUpstreamRequest settings mgr respond mwreq+ | Wai.requestMethod mwreq == "CONNECT" =+ respond $ responseRawSource (handleConnect mwreq)+ (Wai.responseLBS HT.status500 [("Content-Type", "text/plain")] "No support for responseRaw")+ | otherwise = do+ hreq0 <- HC.parseUrl $ BS.unpack (Wai.rawPathInfo mwreq <> Wai.rawQueryString mwreq)+ let hreq = hreq0+ { HC.method = Wai.requestMethod mwreq+ , HC.requestHeaders = filter dropRequestHeader $ Wai.requestHeaders mwreq+ , HC.redirectCount = 0 -- Always pass redirects back to the client.+ , HC.requestBody =+ case Wai.requestBodyLength mwreq of+ Wai.ChunkedBody ->+ HC.requestBodySourceChunkedIO (sourceRequestBody mwreq)+ Wai.KnownLength l ->+ HC.requestBodySourceIO (fromIntegral l) (sourceRequestBody mwreq)+ , HC.decompress = const True+ , HC.checkStatus = \_ _ _ -> Nothing+ }+ handle (respond . errorResponse) $+ HC.withResponse hreq mgr $ \res -> do+ let body = mapOutput (Chunk . fromByteString) . HCC.bodyReaderSource $ HC.responseBody res+ headers = (CI.mk "X-Via-Proxy", "yes") : filter dropResponseHeader (HC.responseHeaders res)+ respond $ responseSource (HC.responseStatus res) headers body where- handleHttpReply close status hversion 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 hversion 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- liftIO $- connSendMany conn $ L.toChunks $ toLazyByteString- $ headers (httpVersion req) statusConnectOK [] False- void $ allocate (forkIO $ do- wrTh <- T.registerKillThread tm- runResourceT (connSource uconn th C.$$ connSink conn wrTh)- T.cancel wrTh- ) killThread- connSource conn th C.$$ connSink uconn th- return False- Left errorMsg ->- failRequest th conn req errorMsg ("PROXY FAILURE\r\n" `mappend` errorMsg)--statusConnectOK :: H.Status-statusConnectOK = H.Status 200 "Connection established"--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- )+ dropRequestHeader (k, _) = k `notElem`+ [ "content-encoding"+ , "content-length"+ ]+ dropResponseHeader (k, _) = k `notElem` [] --- 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+ errorResponse :: SomeException -> Wai.Response+ errorResponse = proxyOnException settings . toException -managerSettingsNoCheck :: HC.ManagerSettings-managerSettingsNoCheck =- HC.def { HC.managerCheckCerts = \ _ _ -> return CertificateUsageAccept }+handleConnect :: Wai.Request -> Source IO BS.ByteString -> Sink BS.ByteString IO () -> IO ()+handleConnect wreq fromClient toClient = do+ let (host, port) =+ case BS.break (== ':') $ Wai.rawPathInfo wreq of+ (x, "") -> (x, 80)+ (x, y) ->+ case BS.readInt $ BS.drop 1 y of+ Just (port', _) -> (x, port')+ Nothing -> (x, 80)+ settings = clientSettings port host+ runTCPClient settings $ \ad -> do+ yield "HTTP/1.1 200 OK\r\n\r\n" $$ toClient+ race_+ (fromClient $$ NC.appSink ad)+ (NC.appSource ad $$ toClient)
+ Network/HTTP/Proxy/Request.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE CPP, OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- License : BSD3+------------------------------------------------------------++module Network.HTTP.Proxy.Request+ ( Port+ , Request (..)++ , proxyRequest+ , waiRequest+ , waiRequestHost+ )+ where++import Data.ByteString.Char8 (ByteString)+import Data.Maybe+import Network.HTTP.Types (Method)++import qualified Network.HTTP.Types as HT+import qualified Network.Wai as Wai++type Port = Int+++-- |+data Request = Request+ {+ -- | Request method such as GET.+ requestMethod :: Method+ -- | HTTP version such as 1.1.+ , httpVersion :: HT.HttpVersion+ -- | A list of header (a pair of key and value) in an HTTP request.+ , requestHeaders :: HT.RequestHeaders+ -- | The part of the URL before the query part.+ , requestPath :: ByteString+ -- | Parsed query string information+ , queryString :: ByteString+ } deriving (Show, Eq)+++proxyRequest :: Wai.Request -> Request+proxyRequest wreq = Request+ (Wai.requestMethod wreq)+ (Wai.httpVersion wreq)+ (Wai.requestHeaders wreq)+ (Wai.rawPathInfo wreq)+ (Wai.rawQueryString wreq)++waiRequest :: Wai.Request -> Request -> Wai.Request+waiRequest original req = original+ { Wai.requestMethod = requestMethod req+ , Wai.httpVersion = httpVersion req+ , Wai.requestHeaders = requestHeaders req+ , Wai.rawPathInfo = requestPath req+ , Wai.rawQueryString = queryString req+ }+++waiRequestHost :: Wai.Request -> ByteString+waiRequestHost req = fromMaybe "???" $ Wai.requestHeaderHost req
− Network/HTTP/Proxy/Timeout.hs
@@ -1,76 +0,0 @@------------------------------------------------------------- Copyright : Michael Snoyman--- License : BSD3------ History:--- This code originated in Michael Snoyman's Warp package. The only changes--- are this file header and the module name.---------------------------------------------------------------module Network.HTTP.Proxy.Timeout- ( Manager- , Handle- , initialize- , register- , registerKillThread- , tickle- , pause- , resume- , cancel- ) where--import qualified Data.IORef as I-import Control.Concurrent (forkIO, threadDelay, myThreadId, killThread)-import Control.Monad (forever)-import qualified Control.Exception as E---- FIXME implement stopManager---- | A timeout manager-newtype Manager = Manager (I.IORef [Handle])-data Handle = Handle (IO ()) (I.IORef State)-data State = Active | Inactive | Paused | Canceled--initialize :: Int -> IO Manager-initialize timeout = do- ref <- I.newIORef []- _ <- forkIO $ forever $ do- threadDelay timeout- ms <- I.atomicModifyIORef ref (\x -> ([], x))- ms' <- go ms id- I.atomicModifyIORef ref (\x -> (ms' x, ()))- return $ Manager ref- where- go [] front = return front- go (m@(Handle onTimeout iactive):rest) front = do- state <- I.atomicModifyIORef iactive (\x -> (go' x, x))- case state of- Inactive -> do- onTimeout `E.catch` ignoreAll- go rest front- Canceled -> go rest front- _ -> go rest (front . (:) m)- go' Active = Inactive- go' x = x--ignoreAll :: E.SomeException -> IO ()-ignoreAll _ = return ()--register :: Manager -> IO () -> IO Handle-register (Manager ref) onTimeout = do- iactive <- I.newIORef Active- let h = Handle onTimeout iactive- I.atomicModifyIORef ref (\x -> (h : x, ()))- return h--registerKillThread :: Manager -> IO Handle-registerKillThread m = do- tid <- myThreadId- register m $ killThread tid--tickle, pause, resume, cancel :: Handle -> IO ()-tickle (Handle _ iactive) = I.writeIORef iactive Active-pause (Handle _ iactive) = I.writeIORef iactive Paused-resume = tickle-cancel (Handle _ iactive) = I.writeIORef iactive Canceled
+ Test/Gen.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Ambiata Pty Ltd+-- Author : Sharif Olorin <sio@tesser.org>+-- License : BSD3+------------------------------------------------------------++module Test.Gen+ ( genWaiRequest+ ) where++import Control.Applicative+import Data.ByteString.Char8 (ByteString)+import Data.CaseInsensitive (CI)+import Data.List (intersperse)+import Data.Monoid ((<>))+import Network.HTTP.Types+import Network.Socket (SockAddr (..), PortNumber)+import Test.QuickCheck++import qualified Data.ByteString.Char8 as BS+import qualified Data.CaseInsensitive as CI+import qualified Data.Text.Encoding as T+import qualified Data.Vault.Lazy as Vault+import qualified Network.Wai.Internal as Wai++genWaiRequest :: Gen Wai.Request+genWaiRequest = do+ method <- genHttpMethod+ version <- genHttpVersion+ pathList <- listOf genAscii+ secure <- elements [ False, True ]+ query <- genQuery+ port <- genPort+ sockAddr <- SockAddrInet port <$> arbitrary+ host <- genHostname+ headers <- genHeaderList+ (bodylen, body) <- genRequestBody+ return $ Wai.Request method version+ (BS.concat $ "/" : intersperse "/" pathList)+ (renderQueryBS query)+ headers secure sockAddr+ (map T.decodeUtf8 pathList)+ query+ (return body) -- requestBody+ Vault.empty+ bodylen -- requestBodyLength+ (Just host) -- requestHeaderHost+ Nothing -- requestHeaderRange+ Nothing -- requestHeaderReferer+ Nothing -- requestHeaderUserAgent+++genRequestBody :: Gen (Wai.RequestBodyLength, ByteString)+genRequestBody =+ let mkResult body = (Wai.KnownLength (fromIntegral $ BS.length body), body)+ in mkResult <$> genAscii+++genHttpMethod :: Gen ByteString+genHttpMethod = elements+ [ "GET", "POST", "HEAD", "PUT", "DELETE", "TRACE", "CONNECT"+ , "OPTIONS", "PATCH"+ ]++genHttpVersion :: Gen HttpVersion+genHttpVersion = elements [ http09, http10, http11 ]++genHostname :: Gen ByteString+genHostname = BS.intercalate "." <$> listOf1 genAscii++genPort :: Gen PortNumber+genPort = fromIntegral <$> arbitrary `suchThat` (\x -> x > 1024 && x < (65536 :: Int))++genHeaderList :: Gen [Header]+genHeaderList = listOf genHeader++genHeader :: Gen Header+genHeader = (,) <$> genHeaderName <*> genAscii++genHeaderName :: Gen (CI ByteString)+genHeaderName = CI.mk <$> genAscii++renderQueryBS :: Query -> ByteString+renderQueryBS [] = ""+renderQueryBS ql =+ let mkPair (name, value) = name <> maybe "" ("=" <>) value+ in "?" <> BS.intercalate "&" (map mkPair ql)++genQuery :: Gen Query+genQuery = listOf genQueryItem++genQueryItem :: Gen QueryItem+genQueryItem = (,) <$> genAscii <*> oneof [Just <$> genAscii, pure Nothing]++genAscii :: Gen ByteString+genAscii = BS.pack <$> do+ srange <- choose (3, 10)+ vectorOf srange $ oneof [choose ('a', 'z'), choose ('0', '9')]
+ Test/Request.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------+-- Copyright (c) Erik de Castro Lopo <erikd@mega-nerd.com>+-- License : BSD3+------------------------------------------------------------++module Test.Request+ ( UriScheme (..)+ , mkGetRequest+ , mkGetRequestWithBody+ , mkPostRequest+ , mkPostRequestBS+ , mkPostRequestBody+ ) where++import Control.Applicative+import Data.ByteString (ByteString)+import Data.Char+import Data.Maybe++import qualified Network.HTTP.Client as HC+import qualified Network.HTTP.Types as HT++import Test.ServerDef+++data UriScheme+ = Http | Https++instance Show UriScheme where+ show Http = "HTTP"+ show Https = "HTTPS"+++mkGetRequest :: UriScheme -> String -> IO HC.Request+mkGetRequest scheme path = mkTestRequest get scheme path Nothing+++mkGetRequestWithBody :: UriScheme -> String -> ByteString -> IO HC.Request+mkGetRequestWithBody scheme path body = mkTestRequestBS get scheme path (Just body)+++mkPostRequest :: UriScheme -> String -> IO HC.Request+mkPostRequest scheme path = mkTestRequest post scheme path Nothing+++mkPostRequestBS :: UriScheme -> String -> ByteString -> IO HC.Request+mkPostRequestBS scheme path body = mkTestRequestBS post scheme path (Just body)+++mkPostRequestBody :: UriScheme -> String -> HC.RequestBody -> IO HC.Request+mkPostRequestBody scheme path body = mkTestRequest post scheme path (Just body)+++mkTestRequestBS :: HT.Method -> UriScheme -> String -> Maybe ByteString -> IO HC.Request+mkTestRequestBS method scheme path mbody = mkTestRequest method scheme path $ HC.RequestBodyBS <$> mbody+++mkTestRequest :: HT.Method -> UriScheme -> String -> Maybe HC.RequestBody -> IO HC.Request+mkTestRequest method scheme path mbody = do+ let port = show $ case scheme of+ Http -> httpTestPort portsDef+ Https -> httpsTestPort portsDef+ url = map toLower (show scheme) ++ "://localhost:" ++ port ++ path+ req <- HC.parseUrl url+ return $ req+ { HC.method = if HC.method req /= method then method else HC.method req+ , HC.requestBody = fromMaybe (HC.requestBody req) mbody+ -- In this test program we want to pass error pages back to the test+ -- function so the error output can be compared.+ , HC.checkStatus = \ _ _ _ -> Nothing+ }+++get, post :: HT.Method+get = HT.methodGet+post = HT.methodPost+
+ Test/ServerDef.hs view
@@ -0,0 +1,48 @@+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- License : BSD3+------------------------------------------------------------++module Test.ServerDef+ ( PortsDef (..)+ , portsDef+ ) where++import Data.List (sort)+import System.IO.Unsafe (unsafePerformIO)+import System.Random++data PortsDef = PortsDef+ { httpTestPort :: Int+ , httpsTestPort :: Int+ }+ deriving Show+++-- Yeah, yeah, unsafePerformIO! Worst thing that can happen is that the tests+-- fail.+{-# NOINLINE portsDef #-}+portsDef :: PortsDef+portsDef = unsafePerformIO getPortsDef+++-- Grab three unique Ints in the range (30000, 60000) and stick them in a+-- PortsDef constructor.+getPortsDef :: IO PortsDef+getPortsDef = do+ vals <- randomRL []+ case sort vals of+ [a, b] -> return $ PortsDef a b+ _ -> getPortsDef+ where+ randomRL :: [Int] -> IO [Int]+ randomRL xs+ | length xs == 2 = return $ sort xs+ | otherwise = do+ x <- randomRIO portRange+ if x `elem` xs+ then randomRL xs+ else randomRL (x:xs)++portRange :: (Int, Int)+portRange = (30000, 60000)
+ Test/TestServer.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- License : BSD3+------------------------------------------------------------++module Test.TestServer+ ( runTestServer+ , runTestServerTLS+ ) where++import Control.Applicative+import Data.ByteString (ByteString)+import Data.List (sort)+import Data.Monoid+import Data.String+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Conduit+import Network.Wai.Handler.Warp+import Network.Wai.Handler.WarpTLS++import Data.ByteString.Lex.Integral (readDecimal_)+import Data.Conduit (($$))+import Data.Int (Int64)++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.Conduit as DC++import qualified Network.HTTP.Proxy.Request as HPR++import Test.ServerDef+import Test.Util+++runTestServer :: IO ()+runTestServer =+ let settings = setPort (httpTestPort portsDef) $ setHost "*6" defaultSettings+ in catchAny (runSettings settings serverApp) print++runTestServerTLS :: IO ()+runTestServerTLS =+ let settings = setPort (httpsTestPort portsDef) $ setHost "*6" defaultSettings+ tlsSettings' = tlsSettings "Test/certificate.pem" "Test/key.pem"+ in catchAny (runTLS tlsSettings' settings serverApp) print++--------------------------------------------------------------------------------++serverApp :: Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived+serverApp req respond+ | rawPathInfo req == "/forbidden" =+ respond $ simpleResponse status403 "This is the forbidden message.\n"++ | rawPathInfo req == "/301" = do+ let respHeaders = [ (hLocation, "http://other-server" <> rawPathInfo req) ]+ respond $ responseLBS status301 respHeaders mempty++ | rawPathInfo req == "/large-get" = do+ let len = readDecimal_ $ BS.drop 1 $ rawQueryString req+ let respHeaders =+ [ (hContentType, "text/plain")+ , (hContentLength, fromString $ show len)+ ]+ respond . responseSource status200 respHeaders $ builderSource len++ | rawPathInfo req == "/secure" = do+ let body = "Using SSL: " <> BS.pack (show $ isSecure req)+ let respHeaders =+ [ (hContentType, "text/plain")+ , (hContentLength, fromString . show $ BS.length body)+ ]+ respond $ responseBS status200 respHeaders body++ | rawPathInfo req == "/large-post" && requestMethod req == "POST" = do+ let len = maybe 0 readDecimal_ (lookup "content-length" $ requestHeaders req) :: Int64+ if len == 0+ then respond $ simpleResponse status400 "Error : POST Content-Length was either missing or zero.\n"+ else respond =<< largePostCheck len (sourceRequestBody req)++ | otherwise = do+ let text = "This is the not-found message.\n\n" : responseBody req+ respHeaders = [ (hContentType, "text/plain") ]+ respond . responseLBS status404 respHeaders $ LBS.fromChunks text+++responseBody :: Request -> [ByteString]+responseBody req =+ [ " Method : " , requestMethod req , "\n"+ , " HTTP Version : " , fromString (show (httpVersion req)) , "\n"+ , " Path Info : " , rawPathInfo req , "\n"+ , " Query String : " , rawQueryString req , "\n"+ , " Server : " , HPR.waiRequestHost req , "\n"+ , " Secure (SSL) : " , fromString (show (isSecure req)), "\n"+ , " Request Headers :\n"+ , headerShow (sort $ requestHeaders req)+ , "\n"+ ]+++largePostCheck :: Int64 -> DC.Source IO ByteString -> IO Response+largePostCheck len rbody =+ maybe success failure <$> (rbody $$ byteSink len)+ where+ success = simpleResponse status200 . BS.pack $ "Post-size: " ++ show len+ failure = simpleResponse status500
+ Test/Util.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE BangPatterns, OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- License : BSD3+------------------------------------------------------------++module Test.Util where++import Blaze.ByteString.Builder+import Control.Applicative+import Control.Concurrent.Async+import Control.Exception hiding (assert)+import Control.Monad (forM_, when, unless)+import Control.Monad.Trans.Resource+import Data.ByteString (ByteString)+import Data.Int (Int64)+import Data.Maybe+import Data.String (fromString)+import Network.Socket+import Network.Connection++import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as LBS+import qualified Data.CaseInsensitive as CI+import qualified Data.Conduit as DC+import qualified Data.Conduit.Binary as CB+import qualified Network.HTTP.Conduit as HC+import qualified Network.HTTP.Types as HT+import qualified Network.Wai as Wai++import Network.HTTP.Proxy.Request+++dumpWaiRequest :: Wai.Request -> IO ()+dumpWaiRequest req =+ mapM_ BS.putStrLn+ [ "------- Wai Request --------------------------------------------------------------"+ , "Method : " , Wai.requestMethod req+ , "HTTP Version : " , fromString (show (Wai.httpVersion req))+ , "Path Info : " , Wai.rawPathInfo req+ , "Query String : " , Wai.rawQueryString req+ , "Server : " , waiRequestHost req+ , "Secure (SSL) : " , fromString (show (Wai.isSecure req))+ , "Remote Host : " , fromString (show (Wai.remoteHost req))+ , "Request Headers :"+ , headerShow (Wai.requestHeaders req)+ ]+++dumpHttpConduitRequest :: HC.Request -> IO ()+dumpHttpConduitRequest req =+ mapM_ BS.putStrLn+ [ "------- HttpConduit Request ------------------------------------------------------"+ , "Method : " , HC.method req+ , "Secure (SSL) : " , fromString (show (HC.secure req))+ , "Host Name : " , HC.host req+ , "Host Port : " , fromString (show (HC.port req))+ , "Path : " , HC.path req+ , "Query String : " , HT.urlDecode False (HC.queryString req)+ , "Request Headers :"+ , headerShow (HC.requestHeaders req)+ ]+++dumpHttpResponse :: HT.Status -> HT.ResponseHeaders -> IO ()+dumpHttpResponse s rh = do+ mapM_ BS.putStrLn+ [ "------- Response from upsteam ----------------------------------------------------"+ , "HTTP/1.0 ", BS.pack (show (HT.statusCode s)), " ", HT.statusMessage s+ ]+ BS.putStr . BS.concat $ map (\ (f, v) -> BS.concat [ " ", CI.original f, ": ", v, "\n" ]) rh+++headerShow :: [HT.Header] -> ByteString+headerShow headers =+ BS.concat $ map hdrShow headers+ where+ hdrShow (f, v) = BS.concat [ " ", CI.original f , ": " , v, "\n" ]+++--------------------------------------------------------------------------------++simpleResponse :: HT.Status -> ByteString -> Wai.Response+simpleResponse status text = do+ let respHeaders =+ [ (HT.hContentType, "text/plain")+ , (HT.hContentLength, fromString . show $ BS.length text)+ ]+ responseBS status respHeaders text+++responseBS :: HT.Status -> HT.ResponseHeaders -> ByteString -> Wai.Response+responseBS status headers text =+ Wai.responseLBS status headers$ LBS.fromChunks [text]++--------------------------------------------------------------------------------++data Result = Result+ { resultSecure :: Bool+ , resultStatus :: Int+ , resultHeaders :: [HT.Header]+ , resultBS :: ByteString+ }+++printResult :: Result -> IO ()+printResult (Result _ status headers body) = do+ putStrLn $ "Response status : " ++ show status+ putStrLn "Response headers :"+ BS.putStr $ headerShow headers+ putStrLn "Response body :"+ BS.putStrLn body++--------------------------------------------------------------------------------++-- | Compare results and error out if they're different.+compareResult :: Result -> Result -> IO ()+compareResult (Result secure sa ha ba) (Result _ sb hb bb) = do+ assert (sa == sb) $ "HTTP status codes don't match : " ++ show sa ++ " /= " ++ show sb+ forM_ [ "server", "content-type", "content-length" ] $ \v ->+ assertMaybe (lookup v ha) (lookup v hb) $ \ ja jb ->+ "Header field '" ++ show v ++ "' doesn't match : '" ++ show ja ++ "' /= '" ++ show jb+ assert (ba == bb) $ "HTTP response bodies are different :\n" ++ BS.unpack ba ++ "\n-----------\n" ++ BS.unpack bb+ when (not secure && isJust (lookup "X-Via-Proxy" ha)) $+ error "Error: Direct connection should not contain 'X-Via-Proxy' header."+ when (not secure && isNothing (lookup "X-Via-Proxy" hb)) $+ error "Error: Direct connection should not contain 'X-Via-Proxy' header."+ where+ assert :: Bool -> String -> IO ()+ assert b = unless b . error++ assertMaybe :: Eq a => Maybe a -> Maybe a -> (a -> a -> String) -> IO ()+ assertMaybe Nothing _ _ = return ()+ assertMaybe _ Nothing _ = return ()+ assertMaybe (Just a) (Just b) fmsg = unless (a == b) . error $ fmsg a b+++testSingleUrl :: Bool -> Int -> HC.Request -> IO ()+testSingleUrl debug testProxyPort request = do+ direct <- httpRun request+ proxy <- httpRun $ addTestProxy testProxyPort request+ when debug $ do+ printResult direct+ printResult proxy+ compareResult direct proxy+++addTestProxy :: Int -> HC.Request -> HC.Request+addTestProxy = HC.addProxy "localhost"+++-- | Use HC.http to fullfil a HC.Request. We need to wrap it because the+-- Response contains a Source which we need to read to generate our result.+httpRun :: HC.Request -> IO Result+httpRun req = do+ mgr <- HC.newManager $ HC.mkManagerSettings (TLSSettingsSimple True False False) Nothing+ runResourceT $ do+ resp <- HC.http (modifyRequest req) mgr+ let contentLen = readInt64 <$> lookup HT.hContentLength (HC.responseHeaders resp)+ bodyText <- checkBodySize (HC.responseBody resp) contentLen+ return $ Result (HC.secure req) (HT.statusCode $ HC.responseStatus resp)+ (HC.responseHeaders resp) bodyText+ where+ modifyRequest r = r { HC.redirectCount = 0 }+++checkBodySize :: (Monad f, Functor f) => DC.ResumableSource f ByteString -> Maybe Int64 -> f ByteString+checkBodySize bodySrc Nothing = fmap (BS.concat . LBS.toChunks) $ bodySrc DC.$$+- CB.take 1000+checkBodySize bodySrc (Just len) = do+ let blockSize = 1000+ if len <= blockSize+ then checkBodySize bodySrc Nothing+ else fromMaybe "Success" <$> (bodySrc DC.$$+- byteSink len)+++byteSink :: Monad m => Int64 -> DC.Sink ByteString m (Maybe ByteString)+byteSink bytes = sink 0+ where+ sink :: Monad m => Int64 -> DC.Sink ByteString m (Maybe ByteString)+ sink !count = DC.await >>= maybe (closeSink count) (sinkBlock count)++ sinkBlock :: Monad m => Int64 -> ByteString -> DC.Sink ByteString m (Maybe ByteString)+ sinkBlock !count bs = sink (count + fromIntegral (BS.length bs))++ closeSink :: Monad m => Int64 -> m (Maybe ByteString)+ closeSink !count = return $+ if count == bytes+ then Nothing+ else Just . BS.pack $ "Error : Body length " ++ show count+ ++ " should have been " ++ show bytes ++ "."+++builderSource :: Monad m => Int64 -> DC.Source m (DC.Flush Builder)+builderSource = DC.mapOutput (DC.Chunk . fromByteString) . byteSource+++byteSource :: Monad m => Int64 -> DC.Source m ByteString+byteSource bytes = loop 0+ where+ loop :: Monad m => Int64 -> DC.Source m ByteString+ loop !count+ | count >= bytes = return ()+ | count + blockSize64 < bytes = do+ DC.yield bsbytes+ loop $ count + blockSize64+ | otherwise = do+ let n = fromIntegral $ bytes - count+ DC.yield $ BS.take n bsbytes+ return ()++ blockSize = 8192 :: Int+ blockSize64 = fromIntegral blockSize :: Int64+ bsbytes = BS.replicate blockSize '?'+++readInt64 :: ByteString -> Int64+readInt64 = read . BS.unpack+++catchAny :: IO a -> (SomeException -> IO a) -> IO a+catchAny action onE =+ withAsync action waitCatch >>= either onE return+++openLocalhostListenSocket :: IO (Socket, Port)+openLocalhostListenSocket = do+ sock <- socket AF_INET Stream defaultProtocol+ addr <- inet_addr "127.0.0.1"+ bind sock (SockAddrInet aNY_PORT addr)+ listen sock 10+ port <- fromIntegral <$> socketPort sock+ return (sock, port)
+ Test/Wai.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- License : BSD3+------------------------------------------------------------++module Test.Wai where++import Network.Wai.Internal+import Test.Hspec++waiShouldBe :: Request -> Request -> Expectation+waiShouldBe a b = do+ requestMethod a `shouldBe` requestMethod b+ httpVersion a `shouldBe` httpVersion b+ rawPathInfo a `shouldBe` rawPathInfo b+ rawQueryString a `shouldBe` rawQueryString b+ requestHeaders a `shouldBe` requestHeaders b+ isSecure a `shouldBe` isSecure b+ remoteHost a `shouldBe` remoteHost b+ pathInfo a `shouldBe` pathInfo b+ queryString a `shouldBe` queryString b+ -- requestBody a+ -- vault a `shouldBe` vault b+ -- requestBodyLength a `shouldBe` requestBodyLength b+ requestHeaderHost a `shouldBe` requestHeaderHost b+ requestHeaderRange a `shouldBe` requestHeaderRange b++
+ Test/testsuite.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE OverloadedStrings #-}+------------------------------------------------------------+-- Copyright : Erik de Castro Lopo <erikd@mega-nerd.com>+-- License : BSD3+------------------------------------------------------------++import Control.Applicative+import Control.Concurrent.Async+import Control.Exception+import Control.Monad+import Control.Monad.Trans.Resource+import Data.Conduit+import Data.Int (Int64)+import Data.Monoid+import Test.Hspec+import Test.Hspec.QuickCheck++import qualified Data.ByteString.Char8 as BS+import qualified Data.CaseInsensitive as CI+import qualified Network.HTTP.Conduit as HC+import qualified Network.HTTP.Types as HT+import qualified Network.Wai as Wai++import Network.HTTP.Proxy+import Network.HTTP.Proxy.Request++import Test.Gen+import Test.QuickCheck+import Test.TestServer+import Test.Util+import Test.Wai+import Test.Request+import Test.ServerDef+++proxyTestDebug :: Bool+proxyTestDebug = False++main :: IO ()+main =+ bracket+ (mapM async [ runTestServer, runTestServerTLS ])+ (mapM_ cancel)+ (const $ runProxyTests proxyTestDebug)++runProxyTests :: Bool -> IO ()+runProxyTests dbg = hspec $ do+ testHelpersTest+ proxyTest Http dbg+ protocolTest+ proxyTest Https dbg+ streamingTest dbg+ requestTest++-- -----------------------------------------------------------------------------++testHelpersTest :: Spec+testHelpersTest =+ -- Test the HTTP and HTTPS servers directly (ie bypassing the Proxy).+ describe "Test helper functionality:" $ do+ it "Byte Sink catches short response bodies." $+ runResourceT (byteSource 80 $$ byteSink 100)+ `shouldReturn` Just "Error : Body length 80 should have been 100."+ it "Byte Source and Sink work in constant memory." $+ runResourceT (byteSource oneBillion $$ byteSink oneBillion) `shouldReturn` Nothing+ it "Byte Sink catches long response bodies." $+ runResourceT (byteSource 110 $$ byteSink 100)+ `shouldReturn` Just "Error : Body length 110 should have been 100."+ it "Client and server can stream GET response." $ do+ let size = oneBillion+ sizeStr = show size+ result <- httpRun =<< mkGetRequest Http ("/large-get?" ++ sizeStr)+ resultStatus result `shouldBe` 200+ lookup HT.hContentLength (resultHeaders result) `shouldBe` Just (BS.pack sizeStr)+ it "Client and server can stream POST request." $ do+ let size = oneMillion+ sizeStr = show size+ body = HC.requestBodySourceIO size $ byteSource size+ result <- httpRun =<< mkPostRequestBody Http ("/large-post?" ++ sizeStr) body+ resultStatus result `shouldBe` 200+ resultBS result `shouldBe` BS.pack ("Post-size: " ++ sizeStr)+++proxyTest :: UriScheme -> Bool -> Spec+proxyTest uris dbg = around withDefaultTestProxy $+ describe ("Simple " ++ show uris ++ " proxying:") $ do+ let tname = show uris+ it (tname ++ " GET.") $ \ testProxyPort ->+ testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/"+ it (tname ++ " GET with query.") $ \ testProxyPort ->+ testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/a?b=1&c=2"+ it (tname ++ " GET with request body.") $ \ testProxyPort ->+ testSingleUrl dbg testProxyPort =<< mkGetRequestWithBody uris "/" "Hello server!"+ it (tname ++ " GET /forbidden returns 403.") $ \ testProxyPort ->+ testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/forbidden"+ it (tname ++ " GET /not-found returns 404.") $ \ testProxyPort ->+ testSingleUrl dbg testProxyPort =<< mkGetRequest uris "/not-found"+ it (tname ++ " POST.") $ \ testProxyPort ->+ testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/"+ it (tname ++ " POST with request body.") $ \ testProxyPort ->+ testSingleUrl dbg testProxyPort =<< mkPostRequestBS uris "/" "Hello server!"+ it (tname ++ " POST /forbidden returns 403.") $ \ testProxyPort ->+ testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/forbidden"+ it (tname ++ " POST /not-found returns 404.") $ \ testProxyPort ->+ testSingleUrl dbg testProxyPort =<< mkPostRequest uris "/not-found"+++protocolTest :: Spec+protocolTest = around withDefaultTestProxy $+ describe "HTTP protocol:" $+ it "Passes re-directs through to client." $ \ testProxyPort -> do+ req <- addTestProxy testProxyPort <$> mkGetRequest Http "/301"+ result <- httpRun req+ resultStatus result `shouldBe` 301+ lookup HT.hLocation (resultHeaders result) `shouldBe` Just "http://other-server/301"+++-- Only need to do this test for HTTP not HTTPS (because it just streams bytes+-- back and forth).+streamingTest :: Bool -> Spec+streamingTest dbg = around withDefaultTestProxy $+ describe "HTTP streaming via proxy:" $ do+ forM_ [ 100, oneThousand, oneMillion, oneBillion ] $ \ size ->+ it ("Http GET " ++ show (size :: Int64) ++ " bytes.") $ \ testProxyPort ->+ testSingleUrl dbg testProxyPort =<< mkGetRequest Http ("/large-get?" ++ show size)+ forM_ [ 100, oneThousand, oneMillion, oneBillion ] $ \ size ->+ it ("Http POST " ++ show (size :: Int64) ++ " bytes.") $ \ testProxyPort -> do+ let body = HC.requestBodySourceIO size $ byteSource size+ testSingleUrl dbg testProxyPort =<< mkPostRequestBody Http ("/large-post?" ++ show size) body+++-- Test that a Request can be pulled apart and reconstructed without losing+-- anything.+requestTest :: Spec+requestTest = describe "Request:" $ do+ prop "Roundtrips with waiRequest." $ forAll genWaiRequest $ \wreq ->+ wreq `waiShouldBe` (waiRequest wreq . proxyRequest) wreq+ it "Can add a request header." $+ withTestProxy proxySettingsAddHeader $ \ testProxyPort -> do+ req <- addTestProxy testProxyPort <$> mkGetRequest Http "/whatever"+ result <- httpRun req+ "X-Test-Header: Blah" `BS.isInfixOf` resultBS result `shouldBe` True+ it "Can rewrite HTTP to HTTPS." $+ withTestProxy proxySettingsHttpsUpgrade $ \ testProxyPort -> do+ req <- addTestProxy testProxyPort <$> mkGetRequest Http "/secure"+ result <- httpRun req+ -- Getting a TlsException shows that we have successfully upgraded+ -- from HTTP to HTTPS. Its not possible to ignore this failure+ -- because its made by the http-conduit inside the proxy.+ BS.take 12 (resultBS result) `shouldBe` "TlsException"+ it "Can provide a proxy Response." $+ withTestProxy proxySettingsProxyResponse $ \ testProxyPort -> do+ req <- addTestProxy testProxyPort <$> mkGetRequest Http "/whatever"+ result <- httpRun req+ resultBS result `shouldBe` "This is the proxy reqponse"++-- -----------------------------------------------------------------------------++oneThousand, oneMillion, oneBillion :: Int64+oneThousand = 1000+oneMillion = oneThousand * oneThousand+oneBillion = oneThousand * oneMillion+++withDefaultTestProxy :: (Int -> IO ()) -> IO ()+withDefaultTestProxy action = do+ (sock, portnum) <- openLocalhostListenSocket+ bracket (async $ runProxySettingsSocket defaultProxySettings sock) cancel (const $ action portnum)+++withTestProxy :: Settings -> (Int -> Expectation) -> Expectation+withTestProxy settings expectation = do+ (sock, portnum) <- openLocalhostListenSocket+ bracket (async $ runProxySettingsSocket settings sock) cancel (const $ expectation portnum)+++proxySettingsAddHeader :: Settings+proxySettingsAddHeader = defaultProxySettings+ { proxyRequestModifier = \ req -> return . Right $ req+ { requestHeaders = (CI.mk "X-Test-Header", "Blah") : requestHeaders req+ }+ }++proxySettingsHttpsUpgrade :: Settings+proxySettingsHttpsUpgrade = defaultProxySettings+ { proxyRequestModifier = \ req -> return . Right $ req { requestPath = httpsUpgrade $ requestPath req }+ }+ where+ httpsUpgrade bs =+ let (start, end) = BS.breakSubstring (bsShow $ httpTestPort portsDef) bs+ https = bsShow $ httpsTestPort portsDef+ in "https" <> BS.drop 4 start <> https <> BS.drop 5 end+ bsShow = BS.pack . show++proxySettingsProxyResponse :: Settings+proxySettingsProxyResponse = defaultProxySettings+ { proxyRequestModifier = const . return $ Left proxyResponse+ }+ where+ proxyResponse :: Wai.Response+ proxyResponse = simpleResponse HT.status200 "This is the proxy reqponse"
http-proxy.cabal view
@@ -1,8 +1,8 @@ Name: http-proxy-Version: 0.0.12+Version: 0.1.0.1 License: BSD3 License-file: LICENSE-Author: Michael Snoyman, Stephen Blackheath, Erik de Castro Lopo+Author: Michael Snoyman, 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@@ -25,38 +25,74 @@ a functions for exception reporting and request re-writing. Eventually, this capability will be expanded to allow optional logging, disk caching etc. -flag network-bytestring- Default: False- Library- Build-Depends: base >= 3 && < 5- , bytestring >= 0.9.1.4 && < 0.10- , wai >= 1.2 && < 1.3- , conduit >= 0.4 && < 0.5- , http-conduit >= 1.4 && < 1.5- , transformers >= 0.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.4 && < 0.5- , tls >= 0.9 && < 0.10- , bytestring-lexing >= 0.4 && < 0.5- , base64-bytestring >= 0.1 && < 0.2- , resourcet >= 0.3 && < 0.4- , ghc-prim- if flag(network-bytestring)- build-depends: network >= 2.2.1.5 && < 2.2.3- , network-bytestring >= 0.1.3 && < 0.1.4- else- build-depends: network >= 2.3 && < 2.4+ Build-Depends: base >= 4 && < 5+ , async >= 2.0+ , blaze-builder >= 0.4+ , bytestring >= 0.10+ , bytestring-lexing >= 0.4+ , case-insensitive >= 1.2+ , conduit >= 1.2+ , conduit-extra >= 1.1+ , http-client >= 0.4+ , http-conduit >= 2.1.7+ , http-types >= 0.8+ , mtl >= 2.1+ , network >= 2.6+ , resourcet >= 1.1+ , tls >= 1.2+ , text >= 1.2+ , transformers >= 0.3+ , wai >= 3.2+ , wai-conduit >= 3.0+ , warp >= 3.0+ , warp-tls >= 3.0+ Exposed-modules: Network.HTTP.Proxy- Other-modules: Network.HTTP.Proxy.Timeout+ Other-modules: Network.HTTP.Proxy.Request ghc-options: -Wall -fwarn-tabs if os(windows) Cpp-options: -DWINDOWS +Test-Suite testsuite+ Type: exitcode-stdio-1.0+ Main-is: Test/testsuite.hs+ build-depends: base+ , async+ , blaze-builder+ , bytestring+ , bytestring-lexing+ , case-insensitive+ , conduit+ , connection >= 0.2+ , conduit-extra+ , http-client+ , http-conduit+ , http-types+ , hspec >= 2.1+ , network+ , QuickCheck >= 2.7+ , random >= 1.1+ , resourcet+ , text+ , vault+ , wai+ , wai-conduit+ , warp+ , warp-tls++ Other-modules: Test.Gen+ , Test.Request+ , Test.ServerDef+ , Test.TestServer+ , Test.Util+ , Test.Wai++ ghc-options: -Wall -fwarn-tabs+ if os(windows)+ Cpp-options: -DWINDOWS+ source-repository head type: git- location: git://github.com/erikd/http-proxy.git+ location: https://github.com/erikd/http-proxy.git