wai-middleware-delegate (empty) → 0.1.0.0
raw patch · 11 files changed
+792/−0 lines, 11 filesdep +asyncdep +basedep +blaze-buildersetup-changed
Dependencies added: async, base, blaze-builder, bytestring, bytestring-lexing, case-insensitive, conduit, conduit-extra, connection, data-default, hspec, http-client, http-client-tls, http-conduit, http-types, network, random, resourcet, streaming-commons, text, vault, wai, wai-conduit, wai-middleware-delegate, warp, warp-tls
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- README.md +34/−0
- Setup.hs +2/−0
- src/Network/Wai/Middleware/Delegate.hs +187/−0
- test/IntegrationTest.hs +110/−0
- test/Test/Fetch.hs +68/−0
- test/Test/HttpReply.hs +93/−0
- test/Test/TestRequests.hs +101/−0
- test/Test/WithExtras.hs +85/−0
- wai-middleware-delegate.cabal +77/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for wai-middleware-delegate++## 0.1.0.0 -- 2018-07-28++* Initial version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Tim Emiola++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Tim Emiola nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,34 @@+# wai-middleware-delegate [](https://circleci.com/gh/adetokunbo/wai-middleware-delegate) [](https://github.com/adetokunbo/wai-middleware-delegate/blob/master/LICENSE)++__wai-middleware-delegate__ is a [WAI](https://hackage.haskell.org/package/wai) middleware that allows requests to be handled by a delegate application that proxies requests to another server.++## Example++```haskell+{-# LANGUAGE OverloadedStrings #-}++import Data.Default (Default (..))+import Network.HTTP.Client.TLS (newTlsManager)+import Network.HTTP.Types (status500)+import Network.Wai+import Network.Wai.Handler.Warp (run)+import Network.Wai.Middleware.Delegate (ProxySettings (..),+ delegateToProxy)++sampleSettings :: ProxySettings+sampleSettings = def { proxyHost = "httpbin.org" }++-- | Create an application that proxies every request to httpbin.org+httpBinDelegate :: ProxySettings -> IO Application+httpBinDelegate s = do+ -- delegate everything!+ let takeItAll = const True+ dummyApp _ respond = respond $ responseLBS status500 [] "I should have been proxied"++ manager <- newTlsManager+ return $ delegateToProxy s manager (takeItAll) dummyApp++main :: IO ()+main = httpBinDelegate sampleSettings >>= run 3000++```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Network/Wai/Middleware/Delegate.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE OverloadedStrings #-}+{-|+Module : Network.Wai.Middleware.Delegate+Description :+ Provides a Wai middleware that delegates handling of requests.++ - delegateTo: delegates handling of requests matching a predicate to a+ delegate Application++ - delegateToProxy : delegates handling of requests matching a predicate to+ different host++ - simpleProxy: is a simple reverse proxy, based on proxyApp of http-proxy by Erik+ de Castro Lopo/Michael Snoyman++Copyright : (c) Tim Emiola, 2018+License : C8D3+Maintainer : tim.emiola@gmail.com+Stability : experimental+-}++module Network.Wai.Middleware.Delegate+ ( delegateTo+ , delegateToProxy+ , simpleProxy+ , ProxySettings(..)+ , RequestPredicate+ )++where++import Control.Exception (SomeException, handle,+ toException)+import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy.Char8 as LC8+import Data.Monoid ((<>))+import Data.String (IsString)++import Blaze.ByteString.Builder (fromByteString)+import Control.Concurrent.Async (race_)+import Data.CaseInsensitive (mk)+import Data.Conduit (ConduitT, Flush (..), Void,+ mapOutput, runConduit, yield,+ (.|))+import Data.Conduit.Network (appSink, appSource)+import Data.Default (Default (..))+import Data.Streaming.Network (ClientSettings, clientSettingsTCP,+ runTCPClient)+import Network.HTTP.Client (Manager, Request (..),+ Response (..), parseRequest,+ withResponse)+import Network.HTTP.Client.Conduit (bodyReaderSource)+import Network.HTTP.Conduit (requestBodySourceChunkedIO,+ requestBodySourceIO)+import Network.HTTP.Types (hContentType,+ internalServerError500, status304,+ status500)+import Network.HTTP.Types.Header (hHost)+import qualified Network.Wai as Wai+import Network.Wai.Conduit (responseRawSource, responseSource,+ sourceRequestBody)++-- | Type alias for a function that determines if a request should be handled by+-- a delegate.+type RequestPredicate = Wai.Request -> Bool++-- | Create a middleware that handles all requests matching a predicate by+-- delegating to an alternate Application.+delegateTo :: Wai.Application -> RequestPredicate -> Wai.Middleware+delegateTo alt f actual req+ | f req = alt req+ | otherwise = actual req++-- | Creates a middleware that handles all requests matching a predicate by+-- proxing them to a host specified by ProxySettings.+delegateToProxy :: ProxySettings -> Manager -> RequestPredicate -> Wai.Middleware+delegateToProxy settings mgr = delegateTo (simpleProxy settings mgr)++-- | Settings that configure the proxy endpoint.+data ProxySettings =+ ProxySettings+ { -- | What to do with exceptions thrown by either the application or server.+ proxyOnException :: SomeException -> Wai.Response+ -- | Timeout value in seconds. Default value: 30+ , proxyTimeout :: Int+ -- | The host being proxied+ , proxyHost :: BS.ByteString+ }++instance Default ProxySettings where+ -- | The default settings for the Proxy server. See the individual settings for+ -- the default value.+ def = ProxySettings+ { -- defaults to returning internal server error showing the error in the body+ proxyOnException = onException+ -- default to 15 seconds+ , proxyTimeout = 15+ , proxyHost = "localhost"+ }+ where+ onException :: SomeException -> Wai.Response+ onException e =+ Wai.responseLBS internalServerError500+ [ (hContentType, "text/plain; charset=utf-8") ] $+ LC8.fromChunks [C8.pack $ show e]++-- | A Wai Application that acts as a http/https proxy.+simpleProxy+ :: ProxySettings+ -> Manager+ -> Wai.Application+simpleProxy settings manager req respond+ -- we may connect requests to secure sites, when we do, we will not have+ -- seen their URI properly+ | Wai.requestMethod req == "CONNECT" = do+ putStrLn $ "Seen a CONNECT !!! to path " ++ (C8.unpack $ Wai.rawPathInfo req)+ respond $ responseRawSource (handleConnect req)+ (Wai.responseLBS status500 [("Content-Type", "text/plain")] "method CONNECT is not supported")+ | otherwise = do+ let scheme+ | Wai.isSecure req = "https"+ | otherwise = "http"+ rawUrl = Wai.rawPathInfo req <> Wai.rawQueryString req+ effectiveUrl = scheme ++ "://" ++ (C8.unpack $ proxyHost settings) ++ C8.unpack (rawUrl)+ newHost = proxyHost settings+ addHostHeader = (:) (hHost, newHost)++ proxyReq' <- parseRequest effectiveUrl+ let onException :: SomeException -> Wai.Response+ onException = proxyOnException settings . toException++ proxyReq = proxyReq'+ { method = Wai.requestMethod req+ , requestHeaders = addHostHeader $ filter dropUpstreamHeaders $ Wai.requestHeaders req+ -- always pass redirects back to the client.+ , redirectCount = 0+ , requestBody =+ case Wai.requestBodyLength req of+ Wai.ChunkedBody ->+ requestBodySourceChunkedIO (sourceRequestBody req)+ Wai.KnownLength l ->+ requestBodySourceIO (fromIntegral l) (sourceRequestBody req)+ -- don't modify the response to ensure consistency with the response headers+ , decompress = const False+ , host = newHost+ }++ respondUpstream = withResponse proxyReq manager $ \res -> do+ let body = mapOutput (Chunk . fromByteString) . bodyReaderSource $ responseBody res+ headers = (mk "X-Via-Proxy", "yes") : (responseHeaders res)+ respond $ responseSource (responseStatus res) headers body++ handle (respond . onException) respondUpstream++handleConnect+ :: Wai.Request+ -> ConduitT () C8.ByteString IO ()+ -> ConduitT C8.ByteString Void IO ()+ -> IO ()+handleConnect req fromClient toClient =+ runTCPClient (toClientSettings req) $ \ad -> do+ runConduit $ yield "HTTP/1.1 200 OK\r\n\r\n" .| toClient+ race_+ (runConduit $ fromClient .| appSink ad)+ (runConduit $ appSource ad .| toClient)++defaultClientPort :: Wai.Request -> Int+defaultClientPort req+ | Wai.isSecure req = 443+ | otherwise = 90++toClientSettings :: Wai.Request -> ClientSettings+toClientSettings req =+ case C8.break (== ':') $ Wai.rawPathInfo req of+ (host, "") -> clientSettingsTCP (defaultClientPort req) host+ (host, port') -> case C8.readInt $ C8.drop 1 port' of+ Just (port, _) -> clientSettingsTCP port host+ Nothing -> clientSettingsTCP (defaultClientPort req) host++dropUpstreamHeaders :: (Eq a, IsString a) => (a, b) -> Bool+dropUpstreamHeaders (k, _) = k `notElem`+ [ "content-encoding"+ , "content-length"+ , "host"+ ]
+ test/IntegrationTest.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad (when)+import Data.Foldable (for_)+import Data.Maybe (maybe)+import System.Environment (lookupEnv)++import Data.Default (Default (..))+import Network.HTTP.Client.TLS (newTlsManager)+import Network.HTTP.Types (status500)+import Network.Wai (Application, rawPathInfo,+ responseLBS)+import Network.Wai.Handler.Warp (Port, testWithApplication)+++import Network.Wai.Middleware.Delegate (ProxySettings (..),+ delegateToProxy)++import Test.Fetch (fetch)+import Test.Hspec+import Test.HttpReply+import Test.TestRequests (RequestBuilder (..),+ buildRequest,+ testNotProxiedRequests,+ testRequests)+import Test.WithExtras (defaultTlsSettings,+ testWithTLSApplication)++defaultTestSettings :: ProxySettings+defaultTestSettings = def { proxyHost = "httpbin.org", proxyTimeout = 2 }++main :: IO ()+main = do+ dumpDebug' <- lookupEnv "DEBUG"+ let dumpDebug = maybe False (const True) dumpDebug'+ hspec $ do+ insecureProxyTest dumpDebug+ secureProxyTest dumpDebug++defaultTestDelegate :: ProxySettings -> IO Application+defaultTestDelegate s = do+ -- delegate everything but /status/418+ let handleFunnyStatus = \req -> rawPathInfo req /= "/status/418"+ dummyApp _ respond = respond $ responseLBS status500 [] "I should have been proxied"++ manager <- newTlsManager+ return $ delegateToProxy s manager (handleFunnyStatus) dummyApp++testWithInsecureProxy :: (Port -> IO ()) -> IO ()+testWithInsecureProxy = testWithApplication (defaultTestDelegate defaultTestSettings)++testWithSecureProxy :: (Port -> IO ()) -> IO ()+testWithSecureProxy = testWithTLSApplication defaultTlsSettings (defaultTestDelegate defaultTestSettings)++onDirectAndProxy :: (HttpReply -> HttpReply -> IO ()) -> Bool -> Int -> RequestBuilder -> IO ()+onDirectAndProxy f debug testProxyPort builder = do+ let proxiedBuilder = builder { rbHost = "localhost", rbPort = Just testProxyPort }+ directReq <- buildRequest builder+ proxiedReq <- buildRequest proxiedBuilder++ when debug $ do+ putStrLn "---------------"+ putStrLn "Direct Request:"+ putStrLn "---------------"+ print directReq+ putStrLn "----------------"+ putStrLn "Proxied Request:"+ putStrLn "----------------"+ print proxiedReq+ proxied <- fetch proxiedReq+ direct <- fetch directReq+ when debug $ do+ putStrLn "Direct:"+ putStrLn "-------"+ print direct+ putStrLn "Proxied:"+ putStrLn "--------"+ print proxied+ f direct proxied++insecureProxyTest :: Bool -> Spec+insecureProxyTest debug =+ let scheme = "HTTP"+ desc = "Simple " ++ scheme ++ " proxying:"+ assertEq = onDirectAndProxy assertHttpRepliesAreEq debug+ assertNeq = onDirectAndProxy assertHttpRepliesDiffer debug+ in+ around testWithInsecureProxy $ describe desc $ do+ for_ testRequests $ \(title, modifier) ->+ it (scheme ++ " " ++ title) $ \port -> assertEq port $ modifier def+ for_ testNotProxiedRequests $ \(title, modifier) ->+ it (scheme ++ " " ++ title) $ \port -> assertNeq port $ modifier def++secureProxyTest :: Bool -> Spec+secureProxyTest debug =+ let+ scheme = "HTTPS"+ desc = "Simple " ++ scheme ++ " proxying:"+ assertEq = onDirectAndProxy assertHttpRepliesAreEq debug+ assertNeq = onDirectAndProxy assertHttpRepliesDiffer debug+ def' = def { rbSecure = True }+ in+ around testWithSecureProxy $ describe desc $ do+ for_ testRequests $ \(title, modifier) ->+ it (scheme ++ " " ++ title) $ \port -> assertEq port $ modifier def'+ for_ testNotProxiedRequests $ \(title, modifier) ->+ it (scheme ++ " " ++ title) $ \port -> assertNeq port $ modifier def'
+ test/Test/Fetch.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.Fetch+ ( fetch+ )+where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8+import qualified Data.ByteString.Lazy as LBS++import Control.Monad.Trans.Resource (runResourceT)+import Data.Conduit (ConduitT, SealedConduitT, Void,+ await, sealConduitT, ($$+-))+import qualified Data.Conduit.Binary as CB+import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Network.Connection (TLSSettings (..))+import Network.HTTP.Client (Request, newManager,+ responseBody, responseHeaders,+ responseStatus, secure, managerSetProxy, proxyFromRequest)+import Network.HTTP.Client.TLS (mkManagerSettings)+import Network.HTTP.Simple (setRequestManager, withResponse)+import Network.HTTP.Types (hContentLength, statusCode)++import Test.HttpReply+++fetch :: Request -> IO HttpReply+fetch req = do+ let mSettings = mkManagerSettings (TLSSettingsSimple True False False) Nothing+ mSettings' = managerSetProxy proxyFromRequest mSettings+ m <- newManager mSettings'+ runResourceT $ withResponse (setRequestManager m req) getSrc+ where+ getSrc resp = do+ let mbBodyLength = readInt64 <$> lookup hContentLength (responseHeaders resp)+ bodyText <- checkBodySize (sealConduitT $ responseBody resp) mbBodyLength+ return $ HttpReply (secure req) (statusCode $ responseStatus resp) (responseHeaders resp) bodyText++bodyCheckBlock :: Int64+bodyCheckBlock = 1000++checkBodySize :: (Monad m) => SealedConduitT () BS.ByteString m () -> Maybe Int64 -> m BS.ByteString+checkBodySize bodySrc Nothing = fmap (BS.concat . LBS.toChunks) $ bodySrc $$+- CB.take $ fromIntegral bodyCheckBlock+checkBodySize bodySrc (Just len)+ | len <= bodyCheckBlock = checkBodySize bodySrc Nothing+ | otherwise = fromMaybe "Success" <$> (bodySrc $$+- sizeCheckSink len)++-- A pipe that counts the size of each incoming C8.Bytestring, when the last is+-- received, the result is Nothing if the size matches the expected value or an+-- error message if it does not.+sizeCheckSink :: Monad m => Int64 -> ConduitT C8.ByteString Void m (Maybe C8.ByteString)+sizeCheckSink expectedSize = sink 0+ where+ sink !count = await >>= maybe (closeSink count) (sinkBlock count)+ sinkBlock !count bs = sink (count + fromIntegral (BS.length bs))++ -- | no more bytes: return Nothing if the count so far matches the expected value+ closeSink !count+ | count == expectedSize = return Nothing+ | otherwise = return $ Just . C8.pack $ "Error : Body length " ++ show count+ ++ " should have been " ++ show expectedSize ++ "."++readInt64 :: C8.ByteString -> Int64+readInt64 = read . C8.unpack
+ test/Test/HttpReply.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.HttpReply+ ( HttpReply(..)+ , HttpReplyMismatch(..)+ , compareHttpReplies+ , assertHttpRepliesAreEq+ , assertHttpRepliesDiffer+ )++where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8+import Data.List (intercalate)+import Data.Maybe (catMaybes, isJust, isNothing)+import Network.HTTP.Types (Header, HeaderName)++import Data.CaseInsensitive (original)++data HttpReply =+ HttpReply+ { hrSecure :: !Bool+ , hrStatus :: !Int+ , hrHeaders :: ![Header]+ , hrBytes :: !BS.ByteString+ }++instance Show HttpReply where+ show r = intercalate "\n" $+ [ "Status: " ++ (show . hrStatus) r+ , "Body:"+ , C8.unpack $ hrBytes r+ ] <> (map (show . concatHeader) $ hrHeaders r)+ where+ concatHeader (f, v) = BS.concat [ " ", original f , ": " , v]++data HttpReplyMismatch+ = StatusMismatch Int Int+ | HeaderMismatch HeaderName (Maybe C8.ByteString) (Maybe C8.ByteString)+ | BodyMismatch BS.ByteString BS.ByteString+ | MissingViaHeader+ | UnexpectedViaHeader+ deriving (Eq)++instance Show HttpReplyMismatch where+ show (StatusMismatch x y)= "HTTP status codes don't match : " ++ show x ++ " /= " ++ show y+ show (HeaderMismatch name x y) = "Header field '" ++ show name ++ "' doesn't match : '" ++ show x ++ "' /= '" ++ show y+ show (BodyMismatch x y) = "HTTP response bodies are different :\n" ++ C8.unpack x ++ "\n-----------\n" ++ C8.unpack y+ show MissingViaHeader = "Error: Proxy connection should contain 'X-Via-Proxy' header."+ show UnexpectedViaHeader = "Error: Direct connection should not contain 'X-Via-Proxy' header."++assertHttpRepliesAreEq :: HttpReply -> HttpReply -> IO ()+assertHttpRepliesAreEq direct proxied = do+ let assertNoMismatches [] = return ()+ assertNoMismatches xs = error $ intercalate "\n" $ map show xs+ assertNoMismatches $ compareHttpReplies direct proxied++assertHttpRepliesDiffer :: HttpReply -> HttpReply -> IO ()+assertHttpRepliesDiffer direct proxied = do+ let assertHasMismatches [] = error "Responses should be different!"+ assertHasMismatches _ = return ()+ assertHasMismatches $ compareHttpReplies direct proxied++compareHttpReplies :: HttpReply -> HttpReply -> [HttpReplyMismatch]+compareHttpReplies direct proxied = catMaybes mbMismatches+ where+ mbMismatches =+ [ compare' hrStatus StatusMismatch+ , compare' hrBytes BodyMismatch+ , missingViaHeader+ , unexpectedViaHeader+ , mismatchedHeader "server"+ , mismatchedHeader "content-type"+ , mismatchedHeader "content-length"+ ]+ wantSecure = hrSecure direct+ maybeHeader n r = lookup n $ hrHeaders r+ compare' f g+ | f direct == f proxied = Nothing+ | otherwise = Just $ g (f direct) (f proxied)+ missingViaHeader+ | not wantSecure && (isJust $ maybeHeader "X-Via-Proxy" direct) = Just UnexpectedViaHeader+ | otherwise = Nothing+ unexpectedViaHeader+ | not wantSecure && (isNothing $ maybeHeader "X-Via-Proxy" proxied) = Just MissingViaHeader+ | otherwise = Nothing+ mismatchedHeader name+ | x' /= y' = Just $ HeaderMismatch name x' y'+ | otherwise = Nothing+ where x' = maybeHeader name direct+ y' = maybeHeader name proxied
+ test/Test/TestRequests.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Test.TestRequests+ ( RequestBuilder(..)+ , buildRequest+ , testRequests+ , testGetRequests+ , testPostRequests+ , testNotProxiedRequests+ ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C8+import Data.Maybe (fromMaybe, maybe)++import Data.Default (Default (..))+import Network.HTTP.Client (Request, RequestBody (..), host, method,+ parseRequest, redirectCount,+ requestBody)+import Network.HTTP.Types (Method, methodGet, methodPost)++data RequestBuilder+ = RequestBuilder+ { rbMethod :: !Method+ , rbSecure :: !Bool+ , rbPath :: !String+ , rbBody :: !(Maybe RequestBody)+ , rbHost :: !BS.ByteString+ , rbPort :: !(Maybe Int)+ }++instance Default RequestBuilder where+ def = RequestBuilder+ { rbMethod = methodGet+ , rbSecure = False+ , rbPath = "/"+ , rbBody = Nothing+ , rbHost = "httpbin.org"+ , rbPort = Nothing+ }++testRequests :: [(String, RequestBuilder -> RequestBuilder)]+testRequests = testGetRequests <> testPostRequests++testGetRequests :: [(String, RequestBuilder -> RequestBuilder)]+testGetRequests =+ [ ("GET"+ , (\builder -> builder {rbPath = "/get"}))+ , ("GET (with a query)"+ , (\builder -> builder {rbPath = "/get?a=10&b=whatever"}))+ , ("GET (with a body)"+ , (\builder -> builder+ { rbPath = "/get"+ , rbBody = Just $ RequestBodyBS "Hello httpbin!"+ }))+ , ("GET (forbidden resource)"+ , (\builder -> builder {rbPath = "/status/403"}))+ , ("GET (missing resource)"+ , (\builder -> builder {rbPath = "/status/404"}))+ ]++testNotProxiedRequests :: [(String, RequestBuilder -> RequestBuilder)]+testNotProxiedRequests =+ [ ("GET (funny resource - differs on proxy)"+ , (\builder -> builder {rbPath = "/status/418"}))+ ]++testPostRequests :: [(String, RequestBuilder -> RequestBuilder)]+testPostRequests =+ [ ("POST"+ , (\builder -> builder {rbMethod = methodPost, rbPath = "/post"}))+ , ("POST (with a query)"+ , (\builder -> builder {rbMethod = methodPost, rbPath = "/post?a=10&b=whatever"}))+ , ("POST (with a body)"+ , (\builder -> builder+ { rbPath = "/post"+ , rbBody = Just $ RequestBodyBS "Hello httpbin!"+ , rbMethod = methodPost+ }))+ , ("POST (forbidden resource)"+ , (\builder -> builder {rbMethod = methodPost, rbPath = "/status/403"}))+ , ("POST (missing resource)"+ , (\builder -> builder {rbMethod = methodPost, rbPath = "/status/404"}))+ ]++-- | Simplifies creation of the requests used in testing+buildRequest :: RequestBuilder -> IO Request+buildRequest RequestBuilder { rbMethod, rbSecure, rbPath , rbBody, rbHost, rbPort } = do+ let scheme+ | rbSecure = "https"+ | otherwise = "http"+ portStr = maybe "" (\x -> ":" ++ show x) rbPort+ url = scheme ++ "://" ++ (C8.unpack rbHost) ++ portStr ++ rbPath+ req <- parseRequest url+ return $ req+ { method = rbMethod+ , requestBody = fromMaybe (requestBody req) rbBody+ , host = rbHost+ , redirectCount = 0+ }
+ test/Test/WithExtras.hs view
@@ -0,0 +1,85 @@+module Test.WithExtras+ ( defaultTlsSettings+ , testWithTLSApplication+ , testWithTLSApplicationSettings+ , withTLSApplication+ , withTLSApplicationSettings+ ) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception+import Control.Monad (when)++import Network.Socket (Socket, close)+import Network.Wai (Application)+import Network.Wai.Handler.Warp.Internal (settingsBeforeMainLoop)++import Network.Wai.Handler.Warp (Port, Settings,+ defaultShouldDisplayException,+ defaultSettings,+ openFreePort)+import Network.Wai.Handler.WarpTLS (TLSSettings,+ runTLSSocket, tlsSettings)++-- | The settings used in the integration tests+defaultTlsSettings :: TLSSettings+defaultTlsSettings = tlsSettings "test/certificate.pem" "test/key.pem"++-- | Runs the given 'Application' on a free port. Passes the port to the given+-- operation and executes it, while the 'Application' is running. Shuts down the+-- server before returning.+withTLSApplication :: TLSSettings -> IO Application -> (Port -> IO a) -> IO a+withTLSApplication = withTLSApplicationSettings defaultSettings++-- | 'withTLSApplication' with given 'Settings'. This will ignore the port value+-- set by 'setPort' in 'Settings'.+withTLSApplicationSettings :: Settings -> TLSSettings -> IO Application -> (Port -> IO a) -> IO a+withTLSApplicationSettings settings' tlsSettings' mkApp action = do+ app <- mkApp+ withFreePort $ \ (port, sock) -> do+ started <- mkWaiter+ let settings =+ settings' {+ settingsBeforeMainLoop+ = notify started () >> settingsBeforeMainLoop settings'+ }+ result <- race+ (runTLSSocket tlsSettings' settings sock app)+ (waitFor started >> action port)+ case result of+ Left () -> throwIO $ ErrorCall "Unexpected: runSettingsSocket exited"+ Right x -> return x++testWithTLSApplication :: TLSSettings -> IO Application -> (Port -> IO a) -> IO a+testWithTLSApplication = testWithTLSApplicationSettings defaultSettings++testWithTLSApplicationSettings :: Settings -> TLSSettings -> IO Application -> (Port -> IO a) -> IO a+testWithTLSApplicationSettings settings tlsSettings' mkApp action = do+ callingThread <- myThreadId+ app <- mkApp+ let wrappedApp request respond =+ app request respond `catch` \ e -> do+ when+ (defaultShouldDisplayException e)+ (throwTo callingThread e)+ throwIO e+ withTLSApplicationSettings settings tlsSettings' (return wrappedApp) action++data Waiter a+ = Waiter {+ notify :: a -> IO (),+ waitFor :: IO a+ }++mkWaiter :: IO (Waiter a)+mkWaiter = do+ mvar <- newEmptyMVar+ return Waiter {+ notify = putMVar mvar,+ waitFor = readMVar mvar+ }++-- | Like 'openFreePort' but closes the socket before exiting.+withFreePort :: ((Port, Socket) -> IO a) -> IO a+withFreePort = bracket openFreePort (close . snd)
+ wai-middleware-delegate.cabal view
@@ -0,0 +1,77 @@+name: wai-middleware-delegate+version: 0.1.0.0+synopsis: WAI middleware that delegates handling of requests.+description: WAI middleware to intercept requests that match a predicate and+ respond to them using other WAI Applications or proxied hosts. [WAI]+ <http://hackage.haskell.org/package/wai>+license: BSD3+license-file: LICENSE+extra-source-files: README.md+author: Tim Emiola+maintainer: tim.emiola@gmail.com+category: Web+homepage: https://github.com/adetokunbo/wai-middleware-delegate+bug-reports: https://github.com/adetokunbo/wai-middleware-delegate/issues+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >= 2.0++source-repository head+ type: git+ location: https://github.com/adetokunbo/wai-middleware-delegate.git++library+ exposed-modules: Network.Wai.Middleware.Delegate+ hs-source-dirs: src+ build-depends: base >= 4.10 && < 5+ , async >= 2.2.1 && < 2.3+ , blaze-builder >= 0.4.1.0 && < 0.5+ , bytestring >= 0.10.8.2 && < 0.11+ , case-insensitive >= 1.2.0.11 && < 1.3+ , conduit >= 1.3.0.3 && < 1.4+ , conduit-extra >= 1.3.0 && < 1.4+ , data-default >= 0.7.1.1 && < 0.8+ , http-client >= 0.5.13.1 && < 0.6+ , http-conduit >= 2.3.2 && < 2.4+ , http-types >= 0.12.1 && < 0.12.2+ , streaming-commons >= 0.2.1.0 && < 0.2.2+ , text >= 1.2.3.0 && < 1.3+ , wai >= 3.2 && < 3.3+ , wai-conduit >= 3.0.0.4 && < 3.1+ default-language: Haskell2010++test-suite integration-test+ type: exitcode-stdio-1.0+ main-is: IntegrationTest.hs+ other-modules: Test.Fetch+ Test.HttpReply+ Test.TestRequests+ Test.WithExtras+ hs-source-dirs: test+ build-depends: base+ , async+ , blaze-builder+ , bytestring+ , bytestring-lexing+ , case-insensitive+ , conduit+ , conduit-extra+ , connection >= 0.2+ , data-default+ , hspec >= 2.1+ , http-client+ , http-client-tls+ , http-conduit+ , http-types+ , network+ , random >= 1.1+ , resourcet+ , text+ , vault+ , wai+ , wai-conduit+ , wai-middleware-delegate+ , warp+ , warp-tls+ default-language: Haskell2010+ ghc-options: -Wall -fwarn-tabs -threaded