diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,9 +1,25 @@ # Revision history for wai-middleware-delegate -## 0.1.0.0 -- 2018-07-28 +`wai-middleware-delegate` uses [PVP Versioning][1]. -* Initial version. +## 0.1.2.1 -- 2021-09-29 +* Relax some dependency upper-bounds +* Compile with a later version of GHC + + +## 0.1.2.0 -- 2020-10-20 + +* Relax some dependency upper-bounds + + ## 0.1.1.0 -- 2018-08-06 * Add configuration for the number of redirects + + +## 0.1.0.0 -- 2018-07-28 + +* Initial version. + +[1]: https://pvp.haskell.org diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,34 +0,0 @@ -# wai-middleware-delegate [![CircleCI](https://circleci.com/gh/adetokunbo/wai-middleware-delegate.svg?style=svg)](https://circleci.com/gh/adetokunbo/wai-middleware-delegate) [![BSD3](https://img.shields.io/badge/license-BSD3-green.svg?dummy)](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 - -``` diff --git a/test/IntegrationTest.hs b/test/IntegrationTest.hs --- a/test/IntegrationTest.hs +++ b/test/IntegrationTest.hs @@ -3,18 +3,16 @@ module Main where +import System.IO import Control.Monad (when) -import Data.Foldable (for_) -import Data.Maybe (maybe) -import System.Environment (lookupEnv) - import Data.Default (Default (..)) +import Data.Foldable (for_) 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 System.Environment (lookupEnv) import Network.Wai.Middleware.Delegate (ProxySettings (..), delegateToProxy) @@ -24,8 +22,8 @@ import Test.HttpReply import Test.TestRequests (RequestBuilder (..), buildRequest, - testOverRedirectedRequests, testNotProxiedRequests, + testOverRedirectedRequests, testRequests) import Test.WithExtras (defaultTlsSettings, testWithTLSApplication) @@ -38,10 +36,13 @@ main :: IO () main = do + hSetBuffering stdin NoBuffering + hSetBuffering stdout NoBuffering dumpDebug' <- lookupEnv "DEBUG" let dumpDebug = maybe False (const True) dumpDebug' hspec $ do - insecureRedirectTest dumpDebug + -- TOOD: reenable when the public /redirect link on http-bin is working ok + -- insecureRedirectTest dumpDebug insecureProxyTest dumpDebug insecureNotProxiedTest dumpDebug secureProxyTest dumpDebug diff --git a/test/Test/HttpReply.hs b/test/Test/HttpReply.hs --- a/test/Test/HttpReply.hs +++ b/test/Test/HttpReply.hs @@ -11,6 +11,7 @@ where +import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 import Data.List (intercalate) @@ -19,13 +20,12 @@ import Data.CaseInsensitive (original) -data HttpReply = - HttpReply - { hrSecure :: !Bool - , hrStatus :: !Int - , hrHeaders :: ![Header] - , hrBytes :: !BS.ByteString - } +data HttpReply = HttpReply + { hrSecure :: !Bool + , hrStatus :: !Int + , hrHeaders :: ![Header] + , hrBytes :: !BS.ByteString + } instance Show HttpReply where show r = intercalate "\n" $ @@ -36,13 +36,13 @@ 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) +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 @@ -68,7 +68,7 @@ where mbMismatches = [ compare' hrStatus StatusMismatch - , compare' hrBytes BodyMismatch + , compareBodys (hrBytes direct) (hrBytes proxied) , missingViaHeader , unexpectedViaHeader , mismatchedHeader "server" @@ -91,3 +91,22 @@ | otherwise = Nothing where x' = maybeHeader name direct y' = maybeHeader name proxied + + +compareBodys :: ByteString -> ByteString -> Maybe HttpReplyMismatch +compareBodys direct proxied = + let direct' = replaceAmznTraceId direct + proxied' = replaceAmznTraceId proxied + compare' a b + | a == b = Nothing + | otherwise = Just $ BodyMismatch a b + in + compare' direct' proxied' + + +replaceAmznTraceId :: ByteString -> ByteString +replaceAmznTraceId x = + let asLines = C8.lines x + checkTrace y = "X-Amzn-Trace-Id" `C8.isInfixOf` y + dropTrace y = if checkTrace y then Nothing else Just y + in C8.unlines $ catMaybes $ dropTrace <$> asLines diff --git a/test/Test/TestRequests.hs b/test/Test/TestRequests.hs --- a/test/Test/TestRequests.hs +++ b/test/Test/TestRequests.hs @@ -13,9 +13,8 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8 -import Data.Maybe (fromMaybe, maybe) - import Data.Default (Default (..)) +import Data.Maybe (fromMaybe) import Network.HTTP.Client (Request, RequestBody (..), host, method, parseRequest, redirectCount, requestBody) diff --git a/wai-middleware-delegate.cabal b/wai-middleware-delegate.cabal --- a/wai-middleware-delegate.cabal +++ b/wai-middleware-delegate.cabal @@ -1,20 +1,27 @@ +cabal-version: 3.0 name: wai-middleware-delegate -version: 0.1.2.0 +version: 0.1.2.1 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] - -license: BSD3 +description: + [WAI](http://hackage.haskell.org/package/wai) middleware that intercepts requests + that match a predicate and responds to them using alternate @WAI@ Applications or + proxied hosts. + + Read this [short example](https://github.com/adetokunbo/wai-middleware-delegate#readme) + for an introduction to its usage. + +license: BSD-3-Clause 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 +homepage: https://github.com/adetokunbo/wai-middleware-delegate#readme +bug-reports: + https://github.com/adetokunbo/wai-middleware-delegate/issues + build-type: Simple -extra-source-files: ChangeLog.md -cabal-version: >= 2.0 +extra-source-files: + ChangeLog.md source-repository head type: git @@ -23,56 +30,61 @@ 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.13.0 - , 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 + build-depends: + async ^>=2.2.1 + , base >=4.10 && <5 + , blaze-builder ^>=0.4.1.0 + , bytestring >=0.10.8.2 && <0.12.0.0 + , case-insensitive ^>=1.2.0.11 + , conduit ^>=1.3.0.3 + , conduit-extra ^>=1.3.0 + , data-default ^>=0.7.1.1 + , http-client >=0.5.13.1 && <0.8.0.0 + , http-conduit ^>=2.3.2 + , http-types >=0.12.1 && <0.13.0 + , streaming-commons >=0.2.1.0 && <0.3.0.0 + , text ^>=1.2.3.0 + , wai ^>=3.2 + , wai-conduit ^>=3.0.0.4 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 + 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 + build-depends: + async + , base + , 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