diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs --- a/Network/HTTP/Proxy.hs +++ b/Network/HTTP/Proxy.hs @@ -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 --- License : BSD3 +{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- Copyright : Michael Snoyman, Erik de Castro Lopo +-- Maintainer : Erik de Castro Lopo +-- 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) diff --git a/Network/HTTP/Proxy/Request.hs b/Network/HTTP/Proxy/Request.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Proxy/Request.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- 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 diff --git a/Network/HTTP/Proxy/Timeout.hs b/Network/HTTP/Proxy/Timeout.hs deleted file mode 100644 --- a/Network/HTTP/Proxy/Timeout.hs +++ /dev/null @@ -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 diff --git a/Test/Gen.hs b/Test/Gen.hs new file mode 100644 --- /dev/null +++ b/Test/Gen.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Ambiata Pty Ltd +-- Author : Sharif Olorin +-- 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')] diff --git a/Test/Request.hs b/Test/Request.hs new file mode 100644 --- /dev/null +++ b/Test/Request.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright (c) Erik de Castro Lopo +-- 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 + diff --git a/Test/ServerDef.hs b/Test/ServerDef.hs new file mode 100644 --- /dev/null +++ b/Test/ServerDef.hs @@ -0,0 +1,48 @@ +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- 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) diff --git a/Test/TestServer.hs b/Test/TestServer.hs new file mode 100644 --- /dev/null +++ b/Test/TestServer.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- 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 diff --git a/Test/Util.hs b/Test/Util.hs new file mode 100644 --- /dev/null +++ b/Test/Util.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- 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) diff --git a/Test/Wai.hs b/Test/Wai.hs new file mode 100644 --- /dev/null +++ b/Test/Wai.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- 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 + + diff --git a/Test/testsuite.hs b/Test/testsuite.hs new file mode 100644 --- /dev/null +++ b/Test/testsuite.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE OverloadedStrings #-} +------------------------------------------------------------ +-- Copyright : Erik de Castro Lopo +-- 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" diff --git a/http-proxy.cabal b/http-proxy.cabal --- a/http-proxy.cabal +++ b/http-proxy.cabal @@ -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