From fe6160790eaea1e2e1d09d0e68c755e030a1622c Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Thu, 23 Feb 2017 04:41:48 +0000 Subject: [PATCH] Add integration test for proxies, fix env parsing --- http-client/ChangeLog.md | 4 + http-client/Network/HTTP/Client/Manager.hs | 10 +- http-client/http-client.cabal | 2 +- integration-test.hs | 162 +++++++++++++++++++++ stack.yaml | 2 +- 5 files changed, 174 insertions(+), 6 deletions(-) create mode 100755 integration-test.hs diff --git a/http-client/ChangeLog.md b/http-client/ChangeLog.md index 4fdaba1e..ebe21867 100644 --- a/http-client/ChangeLog.md +++ b/http-client/ChangeLog.md @@ -1,3 +1,7 @@ +## 0.5.6.1 + +* Fix broken socks5 and socks5h support from previous release + ## 0.5.6 * Added socks5 and socks5h support [#262](https://github.com/snoyberg/http-client/pull/262) diff --git a/http-client/Network/HTTP/Client/Manager.hs b/http-client/Network/HTTP/Client/Manager.hs index aef22610..dfb0561d 100644 --- a/http-client/Network/HTTP/Client/Manager.hs +++ b/http-client/Network/HTTP/Client/Manager.hs @@ -507,13 +507,15 @@ envHelper name eh = do Just str -> do let invalid = throwHttp $ InvalidProxyEnvironmentVariable name (T.pack str) (p, muserpass) <- maybe invalid return $ do + let allowedScheme x = + x == "http:" || + x == "socks5:" || + x == "socks5h:" uri <- case U.parseURI str of - Just u | U.uriScheme u == "http:" -> return u - | U.uriScheme u == "socks5:" -> return u - | U.uriScheme u == "socks5h:" -> return u + Just u | allowedScheme (U.uriScheme u) -> return u _ -> U.parseURI $ "http://" ++ str - guard $ U.uriScheme uri == "http:" + guard $ allowedScheme $ U.uriScheme uri guard $ null (U.uriPath uri) || U.uriPath uri == "/" guard $ null $ U.uriQuery uri guard $ null $ U.uriFragment uri diff --git a/http-client/http-client.cabal b/http-client/http-client.cabal index fec5fb2a..9c75a2e5 100644 --- a/http-client/http-client.cabal +++ b/http-client/http-client.cabal @@ -1,5 +1,5 @@ name: http-client -version: 0.5.6 +version: 0.5.6.1 synopsis: An HTTP client engine description: Hackage documentation generation is not reliable. For up to date documentation, please see: . homepage: https://github.com/snoyberg/http-client diff --git a/integration-test.hs b/integration-test.hs new file mode 100755 index 00000000..b2d058fe --- /dev/null +++ b/integration-test.hs @@ -0,0 +1,162 @@ +#!/usr/bin/env stack +{- stack --install-ghc exec + --package typed-process + --package http-conduit + --package hspec + --package safe-exceptions + + -- ghc -O2 -threaded -Wall -Werror +-} +{-# LANGUAGE OverloadedStrings #-} +import Control.Exception.Safe +import Control.Monad (forM_, void) +import qualified Data.ByteString as B +import Network.HTTP.Client (HttpExceptionContent (..), newManager) +import Network.HTTP.Client.TLS (setGlobalManager, tlsManagerSettings) +import Network.HTTP.Simple +import System.Directory (copyFile, createDirectoryIfMissing) +import System.Environment as E +import System.FilePath (takeDirectory, ()) +import System.Process.Typed +import Test.Hspec + +-- | Main entry point. No arguments: launch the wrapper which will kick +-- off the Docker containers. If given inner, runs the test suite +-- inside the Docker container. +main :: IO () +main = do + args <- getArgs + case args of + [] -> outer + -- withArgs hides the "inner" argument to avoid confusing hspec + ["inner"] -> withArgs [] inner + _ -> error $ "Invalid args: " ++ show args + +-- | Run from outside the container +outer :: IO () +outer = do + -- Kill a previously launched squid container. We ignore any + -- errors in case the container isn't running. + let killit = do + let run = void + . runProcess + . setStdin closed + . setStdout closed + . setStderr closed + run $ proc "docker" $ words "kill http-client-squid" + run $ proc "docker" $ words "rm http-client-squid" + + -- How to launch the Squid proxy container + squid = proc "docker" + $ words "run -d --name=http-client-squid sameersbn/squid:3.3.8-23" + + -- Create the Docker image to run the test suite itself, containing + -- this executable. NOTE: I tried initially just bind-mounting the + -- executable into the running container, but this failed on Gitlab + -- which is using Docker-within-Docker. + let dockerfile = "/tmp/http-client-base/Dockerfile" + dockerfileBS = + "FROM fpco/pid1:16.04\n\ + \RUN apt-get update\n\ + \RUN apt-get install -y iptables curl ca-certificates netbase\n\ + \COPY test-suite /usr/bin/test-suite\n" + + -- Check if the Dockerfile is out of date. We want to avoid updating + -- if we can to not invalidate the Docker cache. + ecurrent <- tryIO $ B.readFile dockerfile + case ecurrent of + Right current | current == dockerfileBS -> return () + _ -> do + createDirectoryIfMissing True $ takeDirectory dockerfile + B.writeFile dockerfile dockerfileBS + + -- Copy over the executable to the temporary directory + exeName <- getExecutablePath + copyFile exeName (takeDirectory dockerfile "test-suite") + + -- Now build the image + runProcess_ $ proc "docker" + [ "build" + , "--tag" + , "http-client-base" + , takeDirectory dockerfile + ] + + -- Launch the squid container, killing a preexisting one if it + -- exists, and then kill the container when we're done. + bracket_ (killit >> readProcess_ squid) killit $ do + -- Run the test suite itself inside a Docker container. We need + -- --privileged to modify the iptables rules. + runProcess_ $ proc "docker" $ words + "run --rm -t --link http-client-squid:squid --privileged\n\ + \http-client-base /usr/bin/test-suite inner" + +-- | Run a set of tests with the given environment variable key/value +-- pair set. Reload the global HTTP manager each time. +describe' :: String -- ^ key + -> String -- ^ value + -> Spec + -> Spec +describe' key val = + describe name . around_ (bracket set unset . const) + where + name = concat [key, "=", val] + set = do + morig <- lookupEnv key + E.setEnv key val + man <- newManager tlsManagerSettings + setGlobalManager man + return morig + unset mval = do + case mval of + Nothing -> unsetEnv key + Just val' -> E.setEnv key val' + setGlobalManager $ error "should not be used" + +-- | Base URL for HTTP or HTTPS httpbin site +base :: Bool -> String +base False = "http://httpbin.org/" +base True = "https://httpbin.org/" + +-- | Ensure that connections fail. +fails :: Bool -- ^ use HTTPS? + -> Spec +fails https = it ("fails to connect " ++ (if https then "secure" else "insecure")) $ + httpLBS (parseRequest_ (base https)) `shouldThrow` (\e -> + case e of + HttpExceptionRequest _ (ConnectionFailure _) -> True + _ -> False) + +-- | Ensure that connections succeed. +succeeds :: Bool -- ^ use HTTPS? + -> Spec +succeeds https = describe ("succeeds " ++ (if https then "secure" else "insecure")) $ do + describe "basic status code check" $ forM_ [200, 400, 500] $ \code -> it (show code) $ do + res <- httpLBS (parseRequest_ (base https ++ "status/" ++ show code)) + getResponseStatusCode res `shouldBe` code + +-- | Code to run the test suites themselves inside the Docker container. +inner :: IO () +inner = do + -- Block all outgoing connections to everything except squid + runProcess_ $ proc "iptables" $ words "-A OUTPUT -p tcp -d squid -j ACCEPT" + runProcess_ $ proc "iptables" $ words "-A OUTPUT -p tcp -j REJECT" + + -- Run the test suite + hspec $ do + describe "no proxy" $ do + fails False + fails True + let values = + [ "http://squid:3128" + , "squid:3128" + , "socks5://squid:3128" + , "socks5h://squid:3128" + ] + forM_ values $ \value -> do + describe' "http_proxy" value $ do + succeeds False + fails True + describe' "https_proxy" value $ do + succeeds True + fails False diff --git a/stack.yaml b/stack.yaml index e97e0e58..03cc8086 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-5.10 +resolver: lts-8.2 packages: - http-client - http-client-tls