diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +### 0.1.1.0 + +* New alternative connection-setup API (`ConnectionAddress` et al.) +* New function `getHeaderMap` for exporting all response headers at once +* Add convenience functions `bytestringBody`, `lazyBytestringBody`, `utf8TextBody`, `utf8LazyTextBody` +* Add support for Brotli HTTP compression + ## 0.1.0.0 * First version. Released on an unsuspecting world. diff --git a/http-common/lib/Network/Http/Internal.hs b/http-common/lib/Network/Http/Internal.hs --- a/http-common/lib/Network/Http/Internal.hs +++ b/http-common/lib/Network/Http/Internal.hs @@ -10,6 +10,7 @@ -- {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide, prune #-} @@ -32,6 +33,7 @@ getStatusCode, getStatusMessage, getHeader, + getHeaderMap, Method(..), Headers, emptyHeaders, @@ -43,6 +45,8 @@ HttpType (getHeaders), HttpParseException(..), + hasBrotli, + -- for testing composeRequestBytes, composeResponseBytes @@ -70,7 +74,7 @@ import Data.Int (Int64) import Data.List (foldl') -import Data.Monoid (mconcat, mempty) +import Data.Monoid as Mon (mconcat, mempty) import Data.Typeable (Typeable) import Data.Word (Word16) @@ -84,6 +88,14 @@ type Port = Word16 +{-# INLINE hasBrotli #-} +hasBrotli :: Bool +#if defined(MIN_VERSION_brotli_streams) +hasBrotli = True +#else +hasBrotli = False +#endif + -- -- | HTTP Methods, as per RFC 2616 -- @@ -178,7 +190,7 @@ headerFields, crlf] where - requestline = mconcat + requestline = Mon.mconcat [method, sp, uri, @@ -250,7 +262,7 @@ data TransferEncoding = None | Chunked -data ContentEncoding = Identity | Gzip | Deflate +data ContentEncoding = Identity | Gzip | Deflate | Br {- Brotli -} | UnknownCE !ByteString deriving (Show) @@ -292,7 +304,13 @@ where h = pHeaders p +-- | Expose all headers in the response as (case-insenstiive) key-value 'Map'ping. -- +-- @since 0.1.1.0 +getHeaderMap :: Response -> Map (CI ByteString) ByteString +getHeaderMap = unWrap . pHeaders + +-- -- | Accessors common to both the outbound and return sides of an HTTP -- connection. -- @@ -366,7 +384,7 @@ show x = S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ joinHeaders $ unWrap x joinHeaders :: Map (CI ByteString) ByteString -> Builder -joinHeaders m = Map.foldrWithKey combine mempty m +joinHeaders m = Map.foldrWithKey combine Mon.mempty m combine :: CI ByteString -> ByteString -> Builder -> Builder combine k v acc = diff --git a/http-common/lib/Network/Http/RequestBuilder.hs b/http-common/lib/Network/Http/RequestBuilder.hs --- a/http-common/lib/Network/Http/RequestBuilder.hs +++ b/http-common/lib/Network/Http/RequestBuilder.hs @@ -43,7 +43,7 @@ import qualified Data.ByteString.Char8 as S import Data.Int (Int64) import Data.List (intersperse) -import Data.Monoid (mconcat) +import Data.Monoid as Mon (mconcat) import Network.Http.Internal @@ -101,7 +101,8 @@ http m p' = do q <- get let h1 = qHeaders q - let h2 = updateHeader h1 "Accept-Encoding" "gzip" + let h2 = updateHeader h1 "Accept-Encoding" $ if hasBrotli then "br, gzip" + else "gzip" let e = case m of PUT -> Chunking @@ -135,7 +136,7 @@ v' :: ByteString v' = if p == 80 then h' - else Builder.toByteString $ mconcat + else Builder.toByteString $ Mon.mconcat [Builder.fromByteString h', Builder.fromString ":", Builder.fromShow p] diff --git a/http-common/lib/Network/Http/Types.hs b/http-common/lib/Network/Http/Types.hs --- a/http-common/lib/Network/Http/Types.hs +++ b/http-common/lib/Network/Http/Types.hs @@ -49,6 +49,7 @@ getStatusCode, getStatusMessage, getHeader, + getHeaderMap, Method(..), -- * Headers diff --git a/http-io-streams.cabal b/http-io-streams.cabal --- a/http-io-streams.cabal +++ b/http-io-streams.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: http-io-streams -version: 0.1.0.0 +version: 0.1.1.0 synopsis: HTTP client based on io-streams description: @@ -30,9 +30,14 @@ type: git location: https://github.com/hvr/http-io-streams.git +flag brotli + manual: True + default: True + description: Build with support for () compression algorithm for . + common settings build-depends: - , base >= 4.5 && < 4.13 + , base >= 4.5 && < 4.14 , blaze-builder ^>= 0.4.1.0 , bytestring ^>= 0.10.0.0 , case-insensitive ^>= 1.2.0.11 @@ -51,13 +56,16 @@ import: settings -- http-streams + if flag(brotli) + build-depends: + brotli-streams ^>= 0.0.0.0 build-depends: , HsOpenSSL ^>= 0.11.2 , attoparsec ^>= 0.13.2.2 , directory ^>= 1.2.0.1 || ^>= 1.3.0.0 , io-streams ^>= 1.5.0.1 - , network ^>= 2.6.0.0 || ^>= 2.7.0.0 + , network ^>= 2.6.0.0 || ^>= 2.7.0.0 || ^>= 2.8.0.0 || ^>= 3.0.0.0 || ^>= 3.1.0.0 , network-uri ^>= 2.6.0.0 , openssl-streams ^>= 1.2.1.3 , text ^>= 1.2.3.0 diff --git a/http-streams/lib/Network/Http/Client.hs b/http-streams/lib/Network/Http/Client.hs --- a/http-streams/lib/Network/Http/Client.hs +++ b/http-streams/lib/Network/Http/Client.hs @@ -121,6 +121,10 @@ getHostname, sendRequest, emptyBody, + bytestringBody, + lazyBytestringBody, + utf8TextBody, + utf8LazyTextBody, fileBody, inputStreamBody, encodedFormBody, @@ -133,6 +137,7 @@ getStatusCode, getStatusMessage, getHeader, + getHeaderMap, debugHandler, concatHandler, concatHandler', @@ -164,6 +169,12 @@ baselineContextSSL, modifyContextSSL, establishConnection, + + -- * Alternative 'ConnectionAddress' API + ConnectionAddress(..), + connectionAddressFromURI, + connectionAddressFromURL, + openConnectionAddress, -- -- * Testing support -- makeConnection, diff --git a/http-streams/lib/Network/Http/Connection.hs b/http-streams/lib/Network/Http/Connection.hs --- a/http-streams/lib/Network/Http/Connection.hs +++ b/http-streams/lib/Network/Http/Connection.hs @@ -32,17 +32,25 @@ UnexpectedCompression, emptyBody, fileBody, + bytestringBody, + lazyBytestringBody, + utf8TextBody, + utf8LazyTextBody, inputStreamBody, debugHandler, concatHandler ) where import Blaze.ByteString.Builder (Builder) -import qualified Blaze.ByteString.Builder as Builder (flush, fromByteString, toByteString) +import qualified Blaze.ByteString.Builder as Builder (flush, fromByteString, toByteString, fromLazyByteString) +import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder (fromText, fromLazyText) import qualified Blaze.ByteString.Builder.HTTP as Builder (chunkedTransferEncoding, chunkedTransferTerminator) import Control.Exception (bracket) import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as S +import Data.Text (Text) +import qualified Data.Text.Lazy as TL (Text) import Network.Socket import OpenSSL (withOpenSSL) import OpenSSL.Session (SSL, SSLContext) @@ -277,13 +285,11 @@ o2 <- Streams.builderStream o1 return Connection { - cHost = path', + cHost = S.pack path, cClose = close s, cOut = o2, cIn = i } - where - path' = S.pack path -- -- | Having composed a 'Request' object with the headers and metadata for @@ -493,6 +499,37 @@ emptyBody :: OutputStream Builder -> IO () emptyBody _ = return () +-- | Convenience function for sending a strict 'ByteString' as the body of the request. +-- +-- > sendRequest c q (bytestringBody "PING") +-- +-- @since 0.1.1.0 +bytestringBody :: ByteString -> OutputStream Builder -> IO () +bytestringBody bs = Streams.write (Just $! Builder.fromByteString bs) + +-- | Convenience function for sending a lazy 'BL.ByteString' as the body of the request. +-- +-- > sendRequest c q (lazyBytestringBody "PING") +-- +-- @since 0.1.1.0 +lazyBytestringBody :: BL.ByteString -> OutputStream Builder -> IO () +lazyBytestringBody bs = Streams.write (Just $ Builder.fromLazyByteString bs) + +-- | Convenience function for sending a 'Text' value as the (UTF-8 encoded) body of the request. +-- +-- > sendRequest c q (utf8TextBody "PING") +-- +-- @since 0.1.1.0 +utf8TextBody :: Text -> OutputStream Builder -> IO () +utf8TextBody t = Streams.write (Just $! Builder.fromText t) + +-- | Convenience function for sending a lazy 'TL.Text' value as the (UTF-8 encoded) body of the request. +-- +-- > sendRequest c q (utf8LazyTextBody "PING") +-- +-- @since 0.1.1.0 +utf8LazyTextBody :: TL.Text -> OutputStream Builder -> IO () +utf8LazyTextBody t = Streams.write (Just $ Builder.fromLazyText t) -- -- | Specify a local file to be sent to the server as the body of the diff --git a/http-streams/lib/Network/Http/Inconvenience.hs b/http-streams/lib/Network/Http/Inconvenience.hs --- a/http-streams/lib/Network/Http/Inconvenience.hs +++ b/http-streams/lib/Network/Http/Inconvenience.hs @@ -2,6 +2,7 @@ -- HTTP client for use with io-streams -- -- Copyright © 2012-2018 Operational Dynamics Consulting, Pty Ltd +-- © 2018-2019 Herbert Valerio Riedel -- -- 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: @@ -30,6 +31,11 @@ TooManyRedirects(..), HttpClientError(..), + ConnectionAddress(..), + connectionAddressFromURI, + connectionAddressFromURL, + openConnectionAddress, + -- for testing splitURI ) where @@ -39,11 +45,12 @@ fromWord8, toByteString) import qualified Blaze.ByteString.Builder.Char8 as Builder (fromString) import Control.Exception (Exception, bracket, throw) +import Control.Monad (when, unless) import Data.Bits (Bits (..)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import Data.ByteString.Internal (c2w, w2c) -import Data.Char (intToDigit) +import Data.Char (intToDigit, toLower, digitToInt, isHexDigit) import Data.Set (Set) import qualified Data.Set as Set import Data.IORef (IORef, newIORef, readIORef, writeIORef) @@ -52,7 +59,7 @@ import qualified Data.Text.Encoding as T import Data.Typeable (Typeable) import Data.Word (Word16) -import GHC.Exts +import GHC.Exts (Int(..),word2Int#, uncheckedShiftRL#) import GHC.Word (Word8 (..)) import Network.URI (URI (..), URIAuth (..), isAbsoluteURI, parseRelativeReference, parseURI, uriToString) @@ -81,6 +88,16 @@ ------------------------------------------------------------------------------ +unescBytes :: [Char] -> ByteString +unescBytes = S.pack . go + where + go [] = [] + go ('%':h:l:rest) + | isHexDigit h, isHexDigit l = toEnum b : go rest + where + b = (16 * digitToInt h) + digitToInt l + go (c:rest) = c : go rest + -- -- | URL-escapes a string (see -- ) @@ -206,6 +223,119 @@ ports = case uriPort auth of "" -> 443 _ -> read $ tail $ uriPort auth :: Word16 + + +-- | HTTP connection target +-- +-- See also 'connectionAddressFromURL' and 'connectionAddressFromURI'. +-- +-- @since 0.1.1.0 +data ConnectionAddress + = ConnectionAddressHttp !Hostname !Word16 -- ^ Represents @http:\/\/host:port@ + | ConnectionAddressHttps !Hostname !Word16 -- ^ Represents @https:\/\/host:port@ + | ConnectionAddressHttpUnix !ByteString -- ^ Represents @http+unix:\/\/%2Fsome%2Fpath%2Fsocket@ or @unix:\/some\/path\/socket@ ('ByteString' denotes raw filepath and must be at most 104 bytes long) + deriving Show + +-- | Open a 'Connection' to the specified 'ConnectionAddress' +-- +-- This is a simple wrapper over 'openConnection', 'openConnectionSSL', and 'openConnectionUnix'. +-- +-- A subtle difference between @'openConnectionUnix' fp@ and @'openConnectionAddress' ('ConnectionAddressHttpUnix' fp)@ is that the latter sends an empty (but valid) @Host:@ HTTP header by default (unless overriden by 'setHostname'); moreover 'openConnectionUnix' only works with 'FilePath's containing only code-points within the ISO-8859-1 range. +-- +-- This operation is often used in combination with 'withConnection'. +-- +-- @since 0.1.1.0 +openConnectionAddress :: ConnectionAddress -> IO Connection +openConnectionAddress ca = case ca of + ConnectionAddressHttp host port -> openConnection host port + ConnectionAddressHttps host ports -> do + ctx <- readIORef global + openConnectionSSL ctx host ports + ConnectionAddressHttpUnix fp -> do + c <- openConnectionUnix (S.unpack fp) + return c { cHost = mempty } -- NB: HTTP RFC allows empty Host: headers + +-- | Decode 'URL' into 'ConnectionAddress', user-info-part, (escaped) URL path, and optional fragment. +-- +-- The 'URL' argument is expected to be properly escaped according to RFC 3986. +-- +-- This is a wrapper over 'connectionAddressFromURI' +-- +-- @since 0.1.1.0 +connectionAddressFromURL :: URL -> Either String (ConnectionAddress, String, ByteString, String) +connectionAddressFromURL r' = do + r <- either (\_ -> Left "invalid UTF-8 encoding") return (T.decodeUtf8' r') + u <- maybe (Left "invalid URI syntax") return (parseURI (T.unpack r)) + connectionAddressFromURI u + +-- | Decode 'URI' (from the @network-uri@ package) into 'ConnectionAddress', user-info part, (escaped) URL path, and optional fragment. +-- +-- See also 'connectionAddressFromURL' +-- +-- @since 0.1.1.0 +connectionAddressFromURI :: URI -> Either String (ConnectionAddress, String, ByteString, String) +connectionAddressFromURI u = fmap addxinfo $ + case map toLower (uriScheme u) of + "http:" -> do + _ <- getUrlPath + return (ConnectionAddressHttp host (port 80), urlpath) + "https:" -> do + _ <- getUrlPath + return (ConnectionAddressHttps host (port 443), urlpath) + "unix:" -> do + noPort + noHost + when (null (uriPath u)) $ + Left "invalid empty path in unix: URI" + unless (null (uriQuery u)) $ + Left "invalid query component in unix: URI" + unless (null (uriFragment u)) $ + Left "invalid fragment component in unix: URI" + let rfp = unescBytes (uriPath u) + when (S.length rfp > 104) $ + Left "unix domain socket path must be at most 104 bytes long" + when (S.elem '\x00' rfp) $ + Left "unix domain socket path must not contain NUL bytes" + return (ConnectionAddressHttpUnix rfp, "") + "http+unix:" -> do + noPort + fp <- getUnixPath + return (ConnectionAddressHttpUnix fp, urlpath) + _ -> Left ("Unknown URI scheme " ++ uriScheme u) + where + addxinfo (ca,p) = (ca, uriUserInfo auth, p, uriFragment u) + + auth = case uriAuthority u of + Just x -> x + Nothing -> URIAuth "" "" "" + + noPort = if null (uriPort auth) then Right () else Left "invalid port number in URI" + noHost = case uriAuthority u of + Nothing -> return () + Just (URIAuth "" "" "") -> return () + Just _ -> Left "invalid host component in uri" + + getUrlPath = case uriRegName auth of + "" -> Left "missing/empty host component in uri" + p -> Right p + + getUnixPath = case uriRegName auth of + "" -> Left "missing/empty host component in uri" + fp -> do + let rfp = unescBytes fp + when (S.length rfp > 104) $ + Left "unix domain socket path must be at most 104 bytes long" + when (S.elem '\x00' rfp) $ + Left "unix domain socket path must not contain NUL bytes" + Right rfp + + urlpath = S.pack (uriPath u ++ uriQuery u) + + host = S.pack (uriRegName auth) + + port def = case uriPort auth of + "" -> def + _ -> read $ tail $ uriPort auth :: Word16 -- diff --git a/http-streams/lib/Network/Http/ResponseParser.hs b/http-streams/lib/Network/Http/ResponseParser.hs --- a/http-streams/lib/Network/Http/ResponseParser.hs +++ b/http-streams/lib/Network/Http/ResponseParser.hs @@ -16,6 +16,7 @@ -- {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_HADDOCK hide, not-home #-} @@ -50,6 +51,17 @@ import Network.Http.Internal import Network.Http.Utilities +#if defined(MIN_VERSION_brotli_streams) +import qualified System.IO.Streams.Brotli as Brotli + +brotliDecompress :: InputStream ByteString -> IO (InputStream ByteString) +brotliDecompress = Brotli.decompress +#else +brotliDecompress :: InputStream ByteString -> IO (InputStream ByteString) +brotliDecompress _ = throwIO (UnexpectedCompression "br") +#endif + + {- The chunk size coming down from the server is somewhat arbitrary; it's really just an indication of how many bytes need to be read @@ -79,9 +91,12 @@ Nothing -> None let ce = case lookupHeader h "Content-Encoding" of - Just x' -> if mk x' == "gzip" - then Gzip - else Identity + Just x' -> case mk x' of + "gzip" -> Gzip + "br" -> Br + "deflate" -> Deflate + "identity" -> Identity + _ -> UnknownCE x' Nothing -> Identity let nm = case lookupHeader h "Content-Length" of @@ -132,8 +147,10 @@ i3 <- case c of Identity -> App.pure i2 - Gzip -> readCompressedBody i2 - Deflate -> throwIO (UnexpectedCompression $ show c) + Gzip -> Streams.gunzip i2 + Br -> brotliDecompress i2 + Deflate -> throwIO (UnexpectedCompression "deflate") + UnknownCE x -> throwIO (UnexpectedCompression (S.unpack x)) return i3 where @@ -267,11 +284,3 @@ readUnlimitedBody :: InputStream ByteString -> IO (InputStream ByteString) readUnlimitedBody i1 = do return i1 - - ---------------------------------------------------------------------- - -readCompressedBody :: InputStream ByteString -> IO (InputStream ByteString) -readCompressedBody i1 = do - i2 <- Streams.gunzip i1 - return i2