diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,64 +1,2 @@ --- --- HTTP client for use with io-streams --- --- Copyright © 2013 Operational Dynamics Consulting, Pty Ltd --- --- The code in this file, and the program it is a part of, is --- made available to you by its authors as open source software: --- you can redistribute it and/or modify it under the terms of --- the BSD licence. --- - -import Data.Char (toUpper) -import Distribution.Text (display) -import Distribution.PackageDescription (PackageDescription(..)) import Distribution.Simple -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) -import Distribution.Simple.Setup (ConfigFlags) -import Distribution.System (OS (..), buildOS) -import System.IO (IOMode (..), Handle, hPutStrLn, withFile) - -main :: IO () -main = defaultMainWithHooks $ simpleUserHooks { - postConf = configure - } - -{- - Simple detection of which operating system we're building on; - there's no need to link the Cabal logic into our library, so - we'll keep using CPP in Network.Http.Inconvenience. --} - -configure :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () -configure _ _ p _ = do - - withFile "config.h" WriteMode (\h -> do - discoverOperatingSystem h - discoverLibraryVersion h p) - - return () - -discoverOperatingSystem :: Handle -> IO () -discoverOperatingSystem h = do - hPutStrLn h ("#define " ++ s) - - where - o = buildOS - - s = case o of - Linux -> "__LINUX__" - OSX -> "__MACOSX__" - Windows -> "__WINDOWS__" - _ -> "__" ++ up o ++ "__" - - up x = map toUpper (show x) - -discoverLibraryVersion :: Handle -> PackageDescription -> IO () -discoverLibraryVersion h p = do - hPutStrLn h ("#define VERSION \"http-streams/" ++ s ++ "\"") - - where - i = package p - v = pkgVersion i - s = display v - +main = defaultMain diff --git a/http-streams.cabal b/http-streams.cabal --- a/http-streams.cabal +++ b/http-streams.cabal @@ -1,6 +1,6 @@ cabal-version: 1.24 name: http-streams -version: 0.8.6.1 +version: 0.8.7.1 synopsis: An HTTP client using io-streams description: /Overview/ @@ -17,9 +17,9 @@ license-file: LICENCE author: Andrew Cowie maintainer: Andrew Cowie -copyright: © 2012-2018 Operational Dynamics Consulting, Pty Ltd and Others +copyright: © 2012-2019 Operational Dynamics Consulting, Pty Ltd and Others category: Web, IO-Streams -tested-with: GHC == 8.2.2, GHC == 8.4.2 +tested-with: GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.5 stability: experimental homepage: https://github.com/afcowie/http-streams/ bug-reports: https://github.com/afcowie/http-streams/issues @@ -38,11 +38,7 @@ tests/hello.txt tests/hello.html -build-type: Custom - -custom-setup - setup-depends: base >= 4.5, - Cabal >= 1.24 +build-type: Simple flag network-uri description: Get Network.URI from the network-uri package @@ -118,8 +114,8 @@ network >= 2.6, network-uri >= 2.6, openssl-streams >= 1.1 && < 1.4, - snap-core >= 1.0 && < 1.1, - snap-server >= 1.0 && < 1.1, + snap-core >= 1.0 && < 1.2, + snap-server >= 1.1 && < 1.2, system-fileio >= 0.3.10 && < 0.4, system-filepath >= 0.4.1 && < 0.5, text, diff --git a/lib/Network/Http/Client.hs b/lib/Network/Http/Client.hs --- a/lib/Network/Http/Client.hs +++ b/lib/Network/Http/Client.hs @@ -133,6 +133,7 @@ -- * Processing HTTP response receiveResponse, receiveResponseRaw, + unsafeReceiveResponse, UnexpectedCompression, StatusCode, getStatusCode, diff --git a/lib/Network/Http/Connection.hs b/lib/Network/Http/Connection.hs --- a/lib/Network/Http/Connection.hs +++ b/lib/Network/Http/Connection.hs @@ -30,6 +30,7 @@ sendRequest, receiveResponse, receiveResponseRaw, + unsafeReceiveResponse, UnexpectedCompression, emptyBody, fileBody, @@ -490,6 +491,21 @@ where i = cIn c +-- +-- | Handle the response coming back from the server. This function +-- is the same as receiveResponse, but it does not consume the body for +-- you after the handler is done. This means that it can only be safely used +-- if the handler will fully consume the body, there is no body, or when +-- the connection is not being reused (no pipelining). +-- +unsafeReceiveResponse :: Connection -> (Response -> InputStream ByteString -> IO β) -> IO β +unsafeReceiveResponse c handler = do + p <- readResponseHeader i + i' <- readResponseBody p i + + handler p i' + where + i = cIn c -- -- | Use this for the common case of the HTTP methods that only send diff --git a/lib/Network/Http/Inconvenience.hs b/lib/Network/Http/Inconvenience.hs --- a/lib/Network/Http/Inconvenience.hs +++ b/lib/Network/Http/Inconvenience.hs @@ -33,11 +33,10 @@ HttpClientError(..), -- for testing - splitURI + splitURI, + parseURL ) where -#include "config.h" - import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as Builder (fromByteString, fromWord8, toByteString) @@ -60,7 +59,8 @@ import GHC.Exts import GHC.Word (Word8 (..)) import Network.URI (URI (..), URIAuth (..), isAbsoluteURI, - parseRelativeReference, parseURI, uriToString) + parseRelativeReference, + parseURI, escapeURIString, isUnescapedInURI, uriToString) import OpenSSL (withOpenSSL) import OpenSSL.Session (SSLContext) import qualified OpenSSL.Session as SSL @@ -77,11 +77,12 @@ import Network.Http.RequestBuilder import Network.Http.Types -#if defined __LINUX__ || defined __FREEBSD__ +-- (see also http://downloads.haskell.org/~ghc/8.4.2/docs/html/users_guide/phases.html#standard-cpp-macros +-- for a list of predefined CPP macros provided by GHC and/or Cabal; see also the cabal user's guide) +#if defined(linux_HOST_OS) || defined(freebsd_HOST_OS) import System.Directory (doesDirectoryExist) #endif - type URL = ByteString ------------------------------------------------------------------------------ @@ -238,14 +239,14 @@ baselineContextSSL = withOpenSSL $ do ctx <- SSL.context SSL.contextSetDefaultCiphers ctx -#if defined __MACOSX__ +#if defined(darwin_HOST_OS) SSL.contextSetVerificationMode ctx SSL.VerifyNone -#elif defined __WINDOWS__ +#elif defined(mingw32_HOST_OS) SSL.contextSetVerificationMode ctx SSL.VerifyNone -#elif defined __FREEBSD__ +#elif defined(freebsd_HOST_OS) SSL.contextSetCAFile ctx "/usr/local/etc/ssl/cert.pem" SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing -#elif defined __OPENBSD__ +#elif defined(openbsd_HOST_OS) SSL.contextSetCAFile ctx "/etc/ssl/cert.pem" SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing #else @@ -266,7 +267,7 @@ Just u -> u Nothing -> error ("Can't parse URI " ++ r) where - r = T.unpack $ T.decodeUtf8 r' + r = escapeURIString isUnescapedInURI $ T.unpack $ T.decodeUtf8 r' ------------------------------------------------------------------------------ diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -36,7 +36,7 @@ import qualified Data.Text.Encoding as Text import GHC.Generics hiding (Selector) import Network.Socket (SockAddr (..)) -import Network.URI (parseURI) +import Network.URI (parseURI, URI(..), URIAuth(..)) import System.Timeout (timeout) import Test.Hspec (Spec, describe, it) import Test.Hspec.Expectations (Selector, anyException, shouldThrow) @@ -65,7 +65,8 @@ import Network.Http.Client import Network.Http.Connection (Connection (..)) import Network.Http.Inconvenience (HttpClientError (..), - TooManyRedirects (..), splitURI) + TooManyRedirects (..), + splitURI, parseURL) import Network.Http.Internal (Request (..), Response (..), composeRequestBytes, lookupHeader) import Network.Http.ResponseParser (readDecimal, readResponseHeader) @@ -105,6 +106,7 @@ testPostWithForm testGetRedirects testSplitURI + testParseURL testGetLocalRedirects testGetFormatsRequest testExcessiveRedirects @@ -600,7 +602,13 @@ r5 = S.pack "http://google.ru/" assertEqual "Incorrect split uri 5" r5 (splitURI (fromJust $ parseURI a5) r5) +testParseURL = + it "Parse URL with chars needing encoding" $ do + let url = parseURL (Text.encodeUtf8 $ Text.pack "http://example.com/α") + assertEqual "Incorrect URL parsing" + (URI "http:" (Just $ URIAuth "" "example.com" "") "/%CE%B1" "" "") url + testGetFormatsRequest = it "GET includes a properly formatted request path" $ do let url = S.concat ["http://", localhost ] @@ -694,7 +702,6 @@ assertEqual "Incorrect response" "Japan" (gLabel x) assertEqual "Data not parsed as expected" 2008 (fst $ last $ gData x) -- L.putStr $ encodePretty x - {- Go to the trouble to create a Haskell data type representing the JSON feed