request 0.4.2.0 → 0.5.0.0

raw patch · 12 files changed

+684/−197 lines, 12 filesdep ~basedep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, text

API changes (from Hackage documentation)

Files

• README.md +117/−19
• request.cabal +18/−9
• src/Network/HTTP/Request.hs +18/−4
• src/Network/HTTP/Request/Internal/Auth.hs +2/−25
• src/Network/HTTP/Request/Internal/Body.hs +75/−85
• src/Network/HTTP/Request/Internal/Charset.hs +52/−0
• src/Network/HTTP/Request/Internal/Client.hs +26/−12
• src/Network/HTTP/Request/Internal/Query.hs +23/−0
• src/Network/HTTP/Request/Internal/Sse.hs +51/−35
• src/Network/HTTP/Request/Internal/Status.hs +24/−0
• src/Network/HTTP/Request/Internal/Types.hs +1/−1
• test/Spec.hs +277/−7

@@ -2,13 +2,13 @@  ![](https://miro.medium.com/max/1200/1*5KglaZoNp4fNpNHUao5u5w.jpeg) -HTTP client for haskell, inpired by [requests](https://requests.readthedocs.io/) and [http-dispatch](https://github.com/owainlewis/http-dispatch).+HTTP client for haskell, inspired by [requests](https://requests.readthedocs.io/) and [http-dispatch](https://github.com/owainlewis/http-dispatch). -[![Ask DeepWiki](https://deepwiki.com/badge.svg)](https://deepwiki.com/aisk/request)+[![Ask DeepWiki](https://deepwiki.com/badge.svg)](https://deepwiki.com/aisk/haskell-request)  ## Installation -This pacakge is published on [hackage](http://hackage.haskell.org/package/request) with the same name `request`, you can install it with cabal or stack or nix as any other hackage packages.+This package is published on [hackage](http://hackage.haskell.org/package/request) with the same name `request`, you can install it with cabal or stack or nix as any other hackage packages.  ## Usage @@ -62,7 +62,8 @@ Built-in `ToRequestBody` instances and their inferred `Content-Type`:  - `()` → empty body, no Content-Type-- `ByteString` / lazy `ByteString` / `Text` / `String` → `text/plain; charset=utf-8`+- `ByteString` / lazy `ByteString` → `application/octet-stream`+- `Text` / `String` → `text/plain; charset=utf-8` - Any type with a `ToJSON` instance → auto JSON encoding + `application/json` - `Form a` (where `a` has a `ToForm` instance) → URL-encoded + `application/x-www-form-urlencoded` @@ -88,14 +89,16 @@   } deriving (Show) ``` -The response body type `a` can be any type that implements the `FromResponseBody` constraint, allowing flexible handling of response data. Built-in supported types include `String`, `ByteString`, `Text`, and any type with a `FromJSON` instance.+The response body type `a` can be any type that implements the `FromResponse` constraint, allowing flexible handling of response data. Built-in supported types include `String`, `ByteString`, `Text`, and any type with a `FromJSON` instance. +`String` and `Text` bodies are decoded with the charset declared in the response's `Content-Type` header, so a `text/html; charset=GBK` page comes back as proper text. Invalid bytes are replaced with U+FFFD. When the charset is missing or not known to the system, the body is decoded as UTF-8.+ ### send  Once you have constructed your own `Request` record, you can call the `send` function to send it to the server. It automatically serializes the body and infers the `Content-Type` header. The `send` function's type is:  ```haskell-send :: (ToRequestBody a, FromResponseBody b) => Request a -> IO (Response b)+send :: (ToRequestBody a, FromResponse b) => Request a -> IO (Response b) ```  ## JSON Support@@ -216,29 +219,70 @@ As you expected, there are some shortcuts for the most used scenarios.  ```haskell-get    :: (FromResponseBody a) => String -> IO (Response a)-delete :: (FromResponseBody a) => String -> IO (Response a)-post   :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b)-put    :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b)-patch  :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b)+get    :: (FromResponse a) => String -> IO (Response a)+delete :: (FromResponse a) => String -> IO (Response a)+post   :: (ToRequestBody a, FromResponse b) => String -> a -> IO (Response b)+put    :: (ToRequestBody a, FromResponse b) => String -> a -> IO (Response b)+patch  :: (ToRequestBody a, FromResponse b) => String -> a -> IO (Response b) ```  These shortcuts' definitions are simple and direct. You are encouraged to add your own if the built-in does not match your use cases, like add custom headers in every request. +## Query Parameters++`addQuery` appends query parameters to a URL and takes care of the escaping:++```haskell+let url = "https://api.example.com/search" `addQuery` [("q", "haskell request"), ("page", "2")]+response <- get url :: IO (Response String)+-- GET https://api.example.com/search?q=haskell%20request&page=2+```++It is a plain `String -> [(Text, Text)] -> String` function, so it works with `Request` and every shortcut. Parameters already in the URL are kept.+ ## Authentication -Use `basicAuth` or `bearerAuth` to add an `Authorization` header to a request:+`basicAuth` builds the value of a Basic `Authorization` header. Put it in the request's header list yourself:  ```haskell-let basicReq = basicAuth "username" "password" (Request GET url [] ())-basicResponse <- send basicReq :: IO (Response String)+let req = Request GET url [("Authorization", basicAuth "username" "password")] ()+response <- send req :: IO (Response String)+``` -let bearerReq = bearerAuth "token" (Request GET url [] ())-bearerResponse <- send bearerReq :: IO (Response String)+## Checking Response Status++A response with a 4xx or 5xx status is returned as-is. If you prefer to treat error statuses as exceptions, like `raise_for_status` in Python requests, pass the response through `raiseForStatus`:++```haskell+resp <- get "https://httpbin.org/status/404" >>= raiseForStatus :: IO (Response String)+-- throws: StatusException 404 [("Content-Type", ...), ...] ``` -Both helpers replace an existing `Authorization` header, regardless of the header name's casing.+`raiseForStatus` returns the response unchanged when the status is below 400, and throws a `StatusException` carrying the status code and the response headers otherwise: +```haskell+data StatusException = StatusException Int Headers++raiseForStatus :: Response a -> IO (Response a)+```++## Network Errors++Connection failures, timeouts and invalid URLs are reported as `http-client`'s `HttpException`. It is re-exported together with `HttpExceptionContent`, so you can catch it without depending on `http-client` yourself:++```haskell+import Control.Exception (try)+import Network.HTTP.Request++main :: IO ()+main = do+  result <- try (get "https://example.invalid") :: IO (Either HttpException (Response String))+  case result of+    Left (HttpExceptionRequest _ content) -> print content   -- e.g. ConnectionFailure ...+    Left (InvalidUrlException url reason) -> putStrLn (url <> ": " <> reason)+    Right resp -> print resp.status+```+ ## Without Language Extensions  If you prefer not to use the language extensions, you can still use the library with the traditional syntax:@@ -275,11 +319,32 @@  ```haskell newManager :: IO Manager-sendWith   :: (ToRequestBody a, FromResponseBody b) => Manager -> Request a -> IO (Response b)+sendWith   :: (ToRequestBody a, FromResponse b) => Manager -> Request a -> IO (Response b) ```  `Manager` is the same type as `Network.HTTP.Client.Manager`, re-exported for convenience. For deeper configuration (`ManagerSettings`, custom proxies, certificate pinning, etc.) import `Network.HTTP.Client` / `Network.HTTP.Client.TLS` directly and build a `Manager` however you need. `sendWith` accepts it as-is. +### Timeouts++Requests time out after 30 seconds by default, which is the `http-client` default. The timeout covers connecting and waiting for the response headers, not reading the body, so long-lived streams are not cut off. To change it, build a manager with a different `managerResponseTimeout` (in microseconds). This needs `http-client` and `http-client-tls` in your `build-depends`:++```haskell+import Network.HTTP.Request+import qualified Network.HTTP.Client as HC+import qualified Network.HTTP.Client.TLS as TLS++main :: IO ()+main = do+  mgr <- HC.newManager TLS.tlsManagerSettings+    { HC.managerResponseTimeout = HC.responseTimeoutMicro 5000000 }  -- 5 seconds+  resp <- sendWith mgr (Request GET "https://api.example.com/things" [] ()) :: IO (Response String)+  print resp.status+```++Use `HC.responseTimeoutNone` to disable the timeout. A timed out request throws `HttpExceptionRequest` with `ResponseTimeout` or `ConnectionTimeout`.++To apply the same setting to `send` and the shortcut functions, install the manager globally with `TLS.setGlobalManager mgr`.+ ## Streaming Support  For large responses or real-time data, you can stream the response body instead of buffering it all in memory.@@ -345,6 +410,39 @@ - `readNext :: IO (Maybe a)` — reads the next chunk or event; returns `Nothing` when the stream ends - `closeStream :: IO ()` — closes the underlying connection +## Custom Response Types++To support your own response body type, implement `FromResponse`. Its single method receives the response before the body has been read:++```haskell+class FromResponse a where+  fromResponse :: Response (StreamBody ByteString) -> IO a+```++Most instances just want the whole body. `decodeResponse` buffers it, closes the connection and runs a pure decoder that can also look at the status and headers. A `Left` is thrown as `ResponseBodyException`:++```haskell+import Network.HTTP.Request+import qualified Data.ByteString.Lazy.Char8 as LBS++newtype Lines = Lines [LBS.ByteString]++instance FromResponse Lines where+  fromResponse = decodeResponse $ \res ->+    if res.status < 400+      then Right (Lines (LBS.lines res.body))+      else Left ("unexpected status " <> show res.status)+```++The two helpers:++```haskell+bufferResponse :: Response (StreamBody ByteString) -> IO (Response LazyByteString)+decodeResponse :: (Response LazyByteString -> Either String a) -> Response (StreamBody ByteString) -> IO a+```++Use `bufferResponse` when you need IO or want to throw your own exception type. An instance that neither calls these helpers nor returns the stream to the caller must call `closeStream` itself.+ ## API Documents  See the hackage page: http://hackage.haskell.org/package/request/docs/Network-HTTP-Request.html@@ -355,4 +453,4 @@  ### License -Request is distributed by a [BSD license](https://github.com/aisk/request/tree/master/LICENSE).+Request is distributed by a [BSD license](https://github.com/aisk/haskell-request/tree/master/LICENSE).

@@ -1,8 +1,8 @@ name:                request-version:             0.4.2.0--- synopsis:-description:         "HTTP client for haskell, inpired by requests and http-dispatch."-homepage:            https://github.com/aisk/request#readme+version:             0.5.0.0+synopsis:            High level HTTP client for haskell+description:         HTTP client for haskell, inspired by requests and http-dispatch.+homepage:            https://github.com/aisk/haskell-request#readme license:             BSD3 license-file:        LICENSE author:              An Long@@ -15,13 +15,19 @@  library   hs-source-dirs:      src+  -- TODO: Internal.Sse is exposed only so the test suite can import it. Keep it+  -- this way for now. Once internal sublibraries are mature enough, upgrade to+  -- cabal-version 3.0 and move the Internal modules into a private sublibrary.   exposed-modules:     Network.HTTP.Request+                     , Network.HTTP.Request.Internal.Sse   other-modules:       Network.HTTP.Request.Internal.Auth                      , Network.HTTP.Request.Internal.Body+                     , Network.HTTP.Request.Internal.Charset                      , Network.HTTP.Request.Internal.Client-                     , Network.HTTP.Request.Internal.Sse+                     , Network.HTTP.Request.Internal.Query+                     , Network.HTTP.Request.Internal.Status                      , Network.HTTP.Request.Internal.Types-  build-depends:       base               >= 4.7 && < 5+  build-depends:       base               >= 4.16 && < 5                      , aeson              >= 2.0 && < 2.3                      , base64-bytestring  >= 1.2 && < 1.3                      , bytestring         >= 0.10.12 && < 0.13@@ -29,12 +35,13 @@                      , http-client        >= 0.6.4 && < 0.8                      , http-types         >= 0.12.3 && < 0.13                      , http-client-tls    >= 0.3.5 && < 0.4-                     , text               >= 1.2.4 && < 2.2+                     , text               >= 2.0 && < 2.2+  ghc-options:         -Wall   default-language:    Haskell2010  source-repository head   type:     git-  location: https://github.com/aisk/request+  location: https://github.com/aisk/haskell-request  test-suite spec   type:                exitcode-stdio-1.0@@ -43,7 +50,9 @@   build-depends:       base                      , request                      , hspec+                     , http-client        >= 0.6.4 && < 0.8                      , bytestring         >= 0.10.12 && < 0.13-                     , text               >= 1.2.4 && < 2.2+                     , text               >= 2.0 && < 2.2                      , aeson+  ghc-options:         -Wall   default-language:    Haskell2010

@@ -3,25 +3,31 @@ module Network.HTTP.Request   ( Header,     Headers,-    FromResponseBody (..),+    FromResponse (..),     ToRequestBody (..),     ToForm (..),     Form (..),     Manager,+    HttpException (..),+    HttpExceptionContent (..),     Method (..),     Request (..),     Response (..),     ResponseBodyException (..),+    StatusException (..),     StreamBody (..),     SseEvent (..),+    addQuery,     basicAuth,-    bearerAuth,+    bufferResponse,+    decodeResponse,     get,     delete,     patch,     post,     put,     newManager,+    raiseForStatus,     send,     sendWith,     requestMethod,@@ -34,13 +40,16 @@   ) where -import Network.HTTP.Request.Internal.Auth (basicAuth, bearerAuth)+import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..))+import Network.HTTP.Request.Internal.Auth (basicAuth) import Network.HTTP.Request.Internal.Body   ( Form (..),-    FromResponseBody (..),+    FromResponse (..),     ResponseBodyException (..),     ToForm (..),     ToRequestBody (..),+    bufferResponse,+    decodeResponse,   ) import Network.HTTP.Request.Internal.Client   ( Manager,@@ -52,6 +61,11 @@     put,     send,     sendWith,+  )+import Network.HTTP.Request.Internal.Query (addQuery)+import Network.HTTP.Request.Internal.Status+  ( StatusException (..),+    raiseForStatus,   ) import Network.HTTP.Request.Internal.Types   ( Header,

@@ -2,34 +2,11 @@  module Network.HTTP.Request.Internal.Auth   ( basicAuth,-    bearerAuth,   ) where  import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as Base64-import qualified Data.CaseInsensitive as CI-import Network.HTTP.Request.Internal.Types-  ( Request (..),-    requestBody,-    requestHeaders,-    requestMethod,-    requestUrl,-  ) -basicAuth :: BS.ByteString -> BS.ByteString -> Request a -> Request a-basicAuth username password =-  setAuthorizationHeader ("Basic " <> Base64.encode (username <> ":" <> password))--bearerAuth :: BS.ByteString -> Request a -> Request a-bearerAuth token = setAuthorizationHeader ("Bearer " <> token)--setAuthorizationHeader :: BS.ByteString -> Request a -> Request a-setAuthorizationHeader value req =-  Request-    (requestMethod req)-    (requestUrl req)-    ( ("Authorization", value)-        : filter (\(name, _) -> CI.mk name /= CI.mk ("Authorization" :: BS.ByteString)) (requestHeaders req)-    )-    (requestBody req)+basicAuth :: BS.ByteString -> BS.ByteString -> BS.ByteString+basicAuth username password = "Basic " <> Base64.encode (username <> ":" <> password)

@@ -1,32 +1,38 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}  module Network.HTTP.Request.Internal.Body-  ( FromResponseBody (..),+  ( FromResponse (..),     ToRequestBody (..),     ToForm (..),     Form (..),     ResponseBodyException (..),+    bufferResponse,+    decodeResponse,   ) where -import Control.Exception (Exception, SomeException, throwIO, toException)+import Control.Exception (Exception, finally, throwIO)+import Control.Monad (void) import Data.Aeson (AesonException (..), FromJSON, ToJSON, eitherDecode, encode) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS-import qualified Data.CaseInsensitive as CI-import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef)-import Data.Proxy (Proxy (..))+import Data.IORef (newIORef, readIORef, writeIORef) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import qualified Network.HTTP.Client as LowLevelClient-import Network.HTTP.Request.Internal.Sse (findEventSep, parseSseBlock)-import Network.HTTP.Request.Internal.Types (Response (..), SseEvent, StreamBody (..))-import qualified Network.HTTP.Types.Status as LowLevelStatus+import Network.HTTP.Request.Internal.Charset (charsetFromHeaders, decodeText)+import Network.HTTP.Request.Internal.Sse (feedSse, newSseParser)+import Network.HTTP.Request.Internal.Types+  ( Response (Response),+    SseEvent,+    StreamBody (..),+    responseBody,+    responseHeaders,+    responseStatus,+  ) import Network.HTTP.Types.URI (renderSimpleQuery)  newtype ResponseBodyException = ResponseBodyException String@@ -34,77 +40,74 @@  instance Exception ResponseBodyException -class FromResponseBody a where-  fromResponseBody :: LBS.ByteString -> Either String a--  responseBodyException :: proxy a -> String -> SomeException-  responseBodyException _ = toException . ResponseBodyException+class FromResponse a where+  -- | Build the body value from a response whose body has not been read yet.+  -- An instance that does not hand the stream over to the caller must close+  -- it, which 'bufferResponse' and 'decodeResponse' do.+  fromResponse :: Response (StreamBody BS.ByteString) -> IO a -  buildResponse :: LowLevelClient.Request -> LowLevelClient.Manager -> IO (Response a)-  buildResponse llreq manager = do-    llres <- LowLevelClient.httpLbs llreq manager-    case fromLowLevelResponse llres of-      Right res -> return res-      Left err -> throwIO (responseBodyException (Proxy :: Proxy a) err)+-- | Read the whole body into memory and close the stream.+bufferResponse :: Response (StreamBody BS.ByteString) -> IO (Response LBS.ByteString)+bufferResponse res = do+  chunks <- readAll `finally` closeStream stream+  return $ Response (responseStatus res) (responseHeaders res) (LBS.fromChunks chunks)+  where+    stream = responseBody res+    readAll = readNext stream >>= maybe (return []) (\chunk -> (chunk :) <$> readAll) -instance FromResponseBody BS.ByteString where-  fromResponseBody = Right . LBS.toStrict+-- | Buffer the response and decode it with a pure function, throwing+-- 'ResponseBodyException' on failure.+decodeResponse :: (Response LBS.ByteString -> Either String a) -> Response (StreamBody BS.ByteString) -> IO a+decodeResponse decode res =+  bufferResponse res >>= either (throwIO . ResponseBodyException) return . decode -instance FromResponseBody LBS.ByteString where-  fromResponseBody = Right+instance FromResponse BS.ByteString where+  fromResponse = fmap (LBS.toStrict . responseBody) . bufferResponse -instance FromResponseBody T.Text where-  fromResponseBody = Right . T.decodeUtf8Lenient . LBS.toStrict+instance FromResponse LBS.ByteString where+  fromResponse = fmap responseBody . bufferResponse -instance FromResponseBody String where-  fromResponseBody = Right . T.unpack . T.decodeUtf8Lenient . LBS.toStrict+instance FromResponse T.Text where+  fromResponse res = do+    buffered <- bufferResponse res+    decodeText (charsetFromHeaders (responseHeaders buffered)) (LBS.toStrict (responseBody buffered)) -instance {-# OVERLAPPABLE #-} (FromJSON a) => FromResponseBody a where-  fromResponseBody = eitherDecode-  responseBodyException _ = toException . AesonException+instance FromResponse String where+  fromResponse = fmap T.unpack . fromResponse -instance FromResponseBody (StreamBody BS.ByteString) where-  fromResponseBody _ = Left "StreamBody must be built via buildResponse"+instance FromResponse () where+  fromResponse = void . bufferResponse -  buildResponse llreq manager = do-    llres <- LowLevelClient.responseOpen llreq manager-    let status = LowLevelStatus.statusCode . LowLevelClient.responseStatus $ llres-        hdrs = map (\(k, v) -> (CI.original k, v)) (LowLevelClient.responseHeaders llres)-        readNext = do-          chunk <- LowLevelClient.brRead (LowLevelClient.responseBody llres)-          return $ if BS.null chunk then Nothing else Just chunk-    return $ Response status hdrs (StreamBody readNext (LowLevelClient.responseClose llres))+instance {-# OVERLAPPABLE #-} (FromJSON a) => FromResponse a where+  fromResponse res = do+    buffered <- bufferResponse res+    either (throwIO . AesonException) return (eitherDecode (responseBody buffered)) -instance FromResponseBody (StreamBody SseEvent) where-  fromResponseBody _ = Left "StreamBody must be built via buildResponse"+instance FromResponse (StreamBody BS.ByteString) where+  fromResponse = return . responseBody -  buildResponse llreq manager = do-    llres <- LowLevelClient.responseOpen llreq manager-    bufRef <- newIORef BS.empty-    let status = LowLevelStatus.statusCode . LowLevelClient.responseStatus $ llres-        hdrs = map (\(k, v) -> (CI.original k, v)) (LowLevelClient.responseHeaders llres)-        readNext = do-          buf <- readIORef bufRef-          case findEventSep buf of-            Just (blockEnd, afterSep) -> do-              writeIORef bufRef (BS.drop afterSep buf)-              case parseSseBlock (BS.take blockEnd buf) of-                Just event -> return (Just event)-                Nothing -> readNext-            Nothing -> do-              chunk <- LowLevelClient.brRead (LowLevelClient.responseBody llres)-              if BS.null chunk-                then-                  if BS.null buf-                    then return Nothing-                    else do-                      writeIORef bufRef BS.empty-                      return (parseSseBlock buf)-                else do-                  modifyIORef bufRef (<> chunk)-                  readNext-    return $ Response status hdrs (StreamBody readNext (LowLevelClient.responseClose llres))+instance FromResponse (StreamBody SseEvent) where+  fromResponse res = do+    stateRef <- newIORef (newSseParser, [])+    let stream = responseBody res+        nextEvent = do+          (parser, queued) <- readIORef stateRef+          case queued of+            event : rest -> do+              writeIORef stateRef (parser, rest)+              return (Just event)+            [] -> do+              mChunk <- readNext stream+              case mChunk of+                Nothing -> return Nothing+                Just chunk -> do+                  writeIORef stateRef (feedSse parser chunk)+                  nextEvent+    return $ StreamBody nextEvent (closeStream stream) +-- TODO: When request bodies are reworked for file, multipart and streaming+-- uploads, turn this into a single-method ToRequest class, mirroring+-- FromResponse. class ToRequestBody a where   toRequestBody :: a -> BS.ByteString   requestContentType :: a -> Maybe BS.ByteString@@ -112,11 +115,11 @@  instance ToRequestBody BS.ByteString where   toRequestBody = id-  requestContentType _ = Just "text/plain; charset=utf-8"+  requestContentType _ = Just "application/octet-stream"  instance ToRequestBody LBS.ByteString where   toRequestBody = LBS.toStrict-  requestContentType _ = Just "text/plain; charset=utf-8"+  requestContentType _ = Just "application/octet-stream"  instance ToRequestBody T.Text where   toRequestBody = T.encodeUtf8@@ -145,16 +148,3 @@ instance (ToForm a) => ToRequestBody (Form a) where   toRequestBody (Form a) = renderSimpleQuery False (toForm a)   requestContentType _ = Just "application/x-www-form-urlencoded"--fromLowLevelResponse :: (FromResponseBody a) => LowLevelClient.Response LBS.ByteString -> Either String (Response a)-fromLowLevelResponse res =-  let status = LowLevelStatus.statusCode . LowLevelClient.responseStatus $ res-      headers = LowLevelClient.responseHeaders res-   in case fromResponseBody $ LowLevelClient.responseBody res of-        Right body ->-          Right $-            Response-              status-              (map (\(k, v) -> (CI.original k, v)) headers)-              body-        Left err -> Left err

@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Network.HTTP.Request.Internal.Charset+  ( charsetFromHeaders,+    decodeText,+  )+where++import Control.Exception (IOException, catch)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as C+import qualified Data.CaseInsensitive as CI+import Data.Char (isAlphaNum, isAscii, toLower)+import Data.Maybe (listToMaybe)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import GHC.Foreign (peekCStringLen)+import GHC.IO.Encoding (mkTextEncoding)+import Network.HTTP.Request.Internal.Types (Headers)++-- | Extract the charset parameter of the Content-Type header, if any.+charsetFromHeaders :: Headers -> Maybe BS.ByteString+charsetFromHeaders headers = do+  contentType <- lookup "content-type" [(CI.mk k, v) | (k, v) <- headers]+  listToMaybe+    [ charset+      | param <- drop 1 (C.split ';' contentType),+        let (key, value) = C.break (== '=') param,+        CI.mk (C.strip key) == "charset",+        let charset = C.filter (/= '"') (C.strip (C.drop 1 value)),+        not (BS.null charset)+    ]++-- | Decode bytes with the given charset, replacing invalid input with U+FFFD.+-- A missing charset, or one the system does not know, is treated as UTF-8.+decodeText :: Maybe BS.ByteString -> BS.ByteString -> IO T.Text+decodeText charset bytes = case C.map toLower <$> charset of+  Nothing -> return utf8+  Just name+    | name `elem` ["utf-8", "utf8"] -> return utf8+    | name `elem` ["iso-8859-1", "latin1", "us-ascii", "ascii"] -> return (T.decodeLatin1 bytes)+    | C.all isNameChar name -> decodeWith name `catch` \(_ :: IOException) -> return utf8+    | otherwise -> return utf8+  where+    utf8 = T.decodeUtf8Lenient bytes+    isNameChar c = isAscii c && (isAlphaNum c || c `elem` ("-_.:+" :: String))+    -- Other charsets go through the encodings GHC knows about, which is iconv+    -- on POSIX systems and the code pages (e.g. CP936) on Windows.+    decodeWith name = do+      encoding <- mkTextEncoding (C.unpack name ++ "//TRANSLIT")+      T.pack <$> BS.useAsCStringLen bytes (peekCStringLen encoding)

@@ -14,22 +14,25 @@   ) where +import Control.Exception (bracketOnError) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C import qualified Data.CaseInsensitive as CI import Network.HTTP.Client (Manager) import qualified Network.HTTP.Client as LowLevelClient import qualified Network.HTTP.Client.TLS as LowLevelTLSClient-import Network.HTTP.Request.Internal.Body (FromResponseBody (..), ToRequestBody (..))+import Network.HTTP.Request.Internal.Body (FromResponse (..), ToRequestBody (..)) import Network.HTTP.Request.Internal.Types   ( Method (..),-    Request (..),-    Response,+    Request (Request),+    Response (Response),+    StreamBody (StreamBody),     requestBody,     requestHeaders,     requestMethod,     requestUrl,   )+import qualified Network.HTTP.Types.Status as LowLevelStatus  methodToByteString :: Method -> BS.ByteString methodToByteString DELETE = "DELETE"@@ -58,37 +61,48 @@         if hasUserAgent           then []           else [("User-Agent", defaultUserAgent)]+      newHeaders = map (\(k, v) -> (CI.mk k, v)) (headers ++ extraContentType ++ extraUserAgent)+      -- Keep headers derived from the URL (e.g. credentials) unless overridden.+      keptHeaders = filter (\(k, _) -> k `notElem` map fst newHeaders) (LowLevelClient.requestHeaders initReq)   return $     initReq       { LowLevelClient.method = methodToByteString (requestMethod req),-        LowLevelClient.requestHeaders = map (\(k, v) -> (CI.mk k, v)) (headers ++ extraContentType ++ extraUserAgent),+        LowLevelClient.requestHeaders = keptHeaders ++ newHeaders,         LowLevelClient.requestBody = LowLevelClient.RequestBodyBS (toRequestBody body)       }  newManager :: IO Manager newManager = LowLevelTLSClient.newTlsManager -sendWith :: (ToRequestBody a, FromResponseBody b) => Manager -> Request a -> IO (Response b)+sendWith :: (ToRequestBody a, FromResponse b) => Manager -> Request a -> IO (Response b) sendWith manager req = do   llreq <- toLowlevelRequest req-  buildResponse llreq manager+  -- Close the connection if building the body fails before anyone owns it.+  bracketOnError (LowLevelClient.responseOpen llreq manager) LowLevelClient.responseClose $ \llres -> do+    let status = LowLevelStatus.statusCode (LowLevelClient.responseStatus llres)+        headers = map (\(k, v) -> (CI.original k, v)) (LowLevelClient.responseHeaders llres)+        readChunk = do+          chunk <- LowLevelClient.brRead (LowLevelClient.responseBody llres)+          return $ if BS.null chunk then Nothing else Just chunk+        stream = StreamBody readChunk (LowLevelClient.responseClose llres)+    Response status headers <$> fromResponse (Response status headers stream) -send :: (ToRequestBody a, FromResponseBody b) => Request a -> IO (Response b)+send :: (ToRequestBody a, FromResponse b) => Request a -> IO (Response b) send req = do   manager <- LowLevelTLSClient.getGlobalManager   sendWith manager req -get :: (FromResponseBody a) => String -> IO (Response a)+get :: (FromResponse a) => String -> IO (Response a) get url = send $ Request GET url [] () -delete :: (FromResponseBody a) => String -> IO (Response a)+delete :: (FromResponse a) => String -> IO (Response a) delete url = send $ Request DELETE url [] () -post :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b)+post :: (ToRequestBody a, FromResponse b) => String -> a -> IO (Response b) post url body = send $ Request POST url [] body -put :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b)+put :: (ToRequestBody a, FromResponse b) => String -> a -> IO (Response b) put url body = send $ Request PUT url [] body -patch :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b)+patch :: (ToRequestBody a, FromResponse b) => String -> a -> IO (Response b) patch url body = send $ Request PATCH url [] body

@@ -0,0 +1,23 @@+module Network.HTTP.Request.Internal.Query+  ( addQuery,+  )+where++import qualified Data.ByteString.Char8 as C+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Network.HTTP.Types.URI (renderSimpleQuery)++-- | Append query parameters to a URL. Keys and values are UTF-8 encoded and+-- percent-escaped. Parameters already in the URL are kept, and a fragment+-- stays at the end.+addQuery :: String -> [(T.Text, T.Text)] -> String+addQuery url [] = url+addQuery url params = base ++ separator ++ C.unpack rendered ++ fragment+  where+    (base, fragment) = break (== '#') url+    rendered = renderSimpleQuery False [(T.encodeUtf8 k, T.encodeUtf8 v) | (k, v) <- params]+    separator+      | '?' `notElem` base = "?"+      | last base `elem` "?&" = ""+      | otherwise = "&"

@@ -1,46 +1,63 @@ {-# LANGUAGE OverloadedStrings #-}  module Network.HTTP.Request.Internal.Sse-  ( findEventSep,-    parseSseBlock,+  ( SseParser,+    newSseParser,+    feedSse,   ) where  import qualified Data.ByteString as BS import Data.List (foldl')-import Data.Maybe (mapMaybe)+import Data.Maybe (fromMaybe) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Network.HTTP.Request.Internal.Types (SseEvent (..)) -findEventSep :: BS.ByteString -> Maybe (Int, Int)-findEventSep bs =-  foldr-    earlier-    Nothing-    [ tryFind "\r\n\r\n",-      tryFind "\r\n\n",-      tryFind "\r\n\r",-      tryFind "\n\r\n",-      tryFind "\n\n",-      tryFind "\n\r",-      tryFind "\r\r\n",-      tryFind "\r\r"-    ]+-- | Incremental SSE parser state. Feed it chunks with 'feedSse'. Whatever is+-- still buffered when the stream ends is an incomplete event and is dropped.+data SseParser = SseParser+  { -- | Whether the leading UTF-8 BOM has been looked for.+    bomChecked :: Bool,+    -- | Pieces of the current unterminated line, newest first.+    pendingLine :: [BS.ByteString],+    -- | The previous line ended with CR, so a directly following LF belongs to it.+    skipLf :: Bool,+    -- | Fields of the current event, newest first.+    pendingFields :: [(T.Text, T.Text)]+  }++newSseParser :: SseParser+newSseParser = SseParser False [] False []++-- | Feed one chunk and get the events it completed. Each chunk is scanned+-- only once, so the cost is linear in the size of the stream.+feedSse :: SseParser -> BS.ByteString -> (SseParser, [SseEvent])+feedSse parser chunk+  | bomChecked parser = go parser chunk []+  | BS.length buf < BS.length bom && buf `BS.isPrefixOf` bom = (parser {pendingLine = [buf]}, [])+  | otherwise = go parser {bomChecked = True, pendingLine = []} (fromMaybe buf (BS.stripPrefix bom buf)) []   where-    tryFind pat =-      let (h, t) = BS.breakSubstring pat bs-       in if BS.null t then Nothing else Just (BS.length h, BS.length h + BS.length pat)-    earlier a Nothing = a-    earlier Nothing b = b-    earlier a@(Just (s1, e1)) b@(Just (s2, e2))-      | s1 < s2 = a-      | s1 > s2 = b-      | e1 >= e2 = a-      | otherwise = b+    bom = "\xEF\xBB\xBF"+    buf = BS.concat (reverse (chunk : pendingLine parser)) -parseSseField :: T.Text -> Maybe (T.Text, T.Text)-parseSseField line+    go p bs acc+      | BS.null bs = (p, reverse acc)+      | skipLf p = go p {skipLf = False} (if BS.head bs == lf then BS.drop 1 bs else bs) acc+      | BS.null rest = (p {pendingLine = h : pendingLine p}, reverse acc)+      | BS.null line = go p' {pendingFields = []} (BS.drop 1 rest) (maybe acc (: acc) event)+      | otherwise = go p' {pendingFields = maybe id (:) (parseSseField line) (pendingFields p)} (BS.drop 1 rest) acc+      where+        (h, rest) = BS.break (\c -> c == cr || c == lf) bs+        line = BS.concat (reverse (h : pendingLine p))+        p' = p {pendingLine = [], skipLf = BS.head rest == cr}+        event = buildSseEvent (reverse (pendingFields p))++    cr = 13+    lf = 10++parseSseField :: BS.ByteString -> Maybe (T.Text, T.Text)+parseSseField raw   | T.null line = Nothing   | T.head line == ':' = Nothing   | otherwise =@@ -51,13 +68,12 @@                 Just v -> v                 Nothing -> T.drop 1 rest        in Just (name, value)+  where+    line = T.decodeUtf8Lenient raw -parseSseBlock :: BS.ByteString -> Maybe SseEvent-parseSseBlock block =-  let txt = T.replace "\r" "\n" . T.replace "\r\n" "\n" $ T.decodeUtf8Lenient block-      ls = T.lines txt-      fields = mapMaybe parseSseField ls-      dataFields = [v | (k, v) <- fields, k == "data"]+buildSseEvent :: [(T.Text, T.Text)] -> Maybe SseEvent+buildSseEvent fields =+  let dataFields = [v | (k, v) <- fields, k == "data"]       dataVal = T.intercalate "\n" dataFields       lastField name = foldl' (\current (k, v) -> if k == name then Just v else current) Nothing fields       typeVal = lastField "event"

@@ -0,0 +1,24 @@+module Network.HTTP.Request.Internal.Status+  ( StatusException (..),+    raiseForStatus,+  )+where++import Control.Exception (Exception, throwIO)+import Network.HTTP.Request.Internal.Types+  ( Headers,+    Response,+    responseHeaders,+    responseStatus,+  )++data StatusException = StatusException Int Headers+  deriving (Show)++instance Exception StatusException++raiseForStatus :: Response a -> IO (Response a)+raiseForStatus res+  | responseStatus res >= 400 =+      throwIO $ StatusException (responseStatus res) (responseHeaders res)+  | otherwise = return res

@@ -62,7 +62,7 @@     sseType :: Maybe T.Text,     sseId :: Maybe T.Text   }-  deriving (Show)+  deriving (Show, Eq)  requestMethod :: Request a -> Method requestMethod (Request value _ _ _) = value

@@ -7,14 +7,19 @@  module Main where -import Data.Aeson (FromJSON, ToJSON)+import Data.Aeson (AesonException (..), FromJSON, ToJSON)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) import Data.List (isInfixOf) import GHC.Generics (Generic)+import Data.List (mapAccumL) import Network.HTTP.Request+import Network.HTTP.Request.Internal.Sse (feedSse, newSseParser) import Test.Hspec import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Client as HC  data UUID = UUID   { uuid :: String@@ -38,8 +43,229 @@              , ("password", T.encodeUtf8 l.password)              ] +-- | A 200 response whose body yields the given chunks, plus a flag telling+-- whether the stream has been closed.+fakeResponse :: Headers -> [BS.ByteString] -> IO (Response (StreamBody BS.ByteString), IORef Bool)+fakeResponse hdrs chunks = do+  remaining <- newIORef chunks+  closed <- newIORef False+  let next = atomicModifyIORef' remaining $ \case+        [] -> ([], Nothing)+        chunk : rest -> (rest, Just chunk)+  return (Response 200 hdrs (StreamBody next (writeIORef closed True)), closed)++decodeFake :: (FromResponse a) => Headers -> [BS.ByteString] -> IO a+decodeFake hdrs chunks = fakeResponse hdrs chunks >>= fromResponse . fst++-- | A manager whose connections never touch the network. Every connection+-- answers with the given raw HTTP response, and whatever is written to it is+-- collected in the returned reference.+fakeManager :: BS.ByteString -> IO (Manager, IORef BS.ByteString)+fakeManager rawResponse = do+  unread <- newIORef rawResponse+  sent <- newIORef BS.empty+  let connect =+        HC.makeConnection+          (atomicModifyIORef' unread (\bytes -> (BS.empty, bytes)))+          (\bytes -> modifyIORef' sent (<> bytes))+          (return ())+      settings =+        HC.managerSetProxy HC.noProxy $+          HC.defaultManagerSettings {HC.managerRawConnection = return (\_ _ _ -> connect)}+  mgr <- HC.newManager settings+  return (mgr, sent)++okResponse :: BS.ByteString+okResponse = "HTTP/1.1 200 OK\r\nContent-Type: application/json\r\nContent-Length: 14\r\n\r\n{\"uuid\":\"abc\"}"++parseSse :: [BS.ByteString] -> [SseEvent]+parseSse = concat . snd . mapAccumL feedSse newSseParser+ main :: IO () main = hspec $ do+  describe "SSE parser" $ do+    it "should parse events with data, event and id fields" $ do+      parseSse ["event: greet\nid: 1\ndata: hello\n\ndata: world\n\n"]+        `shouldBe` [SseEvent "hello" (Just "greet") (Just "1"), SseEvent "world" Nothing Nothing]++    it "should join multiple data lines and skip comments" $ do+      parseSse [": ping\ndata: line1\ndata:line2\n\n"]+        `shouldBe` [SseEvent "line1\nline2" Nothing Nothing]++    it "should accept CR, LF and CRLF line endings" $ do+      parseSse ["data: a\r\n\r\ndata: b\r\rdata: c\n\n"]+        `shouldBe` [SseEvent "a" Nothing Nothing, SseEvent "b" Nothing Nothing, SseEvent "c" Nothing Nothing]++    it "should parse events split across chunks" $ do+      parseSse ["da", "ta: he", "llo\r", "\n\r", "\ndata: wor", "ld\n", "\n"]+        `shouldBe` [SseEvent "hello" Nothing Nothing, SseEvent "world" Nothing Nothing]++    it "should strip a leading UTF-8 BOM" $ do+      parseSse ["\xEF\xBB\xBF" <> "data: hi\n\n"] `shouldBe` [SseEvent "hi" Nothing Nothing]+      parseSse ["\xEF\xBB", "\xBF" <> "data: hi\n\n"] `shouldBe` [SseEvent "hi" Nothing Nothing]++    it "should discard an incomplete event at the end of the stream" $ do+      parseSse ["data: done\n\ndata: partial\n"] `shouldBe` [SseEvent "done" Nothing Nothing]++  describe "FromResponse" $ do+    it "should decode text with the charset from the Content-Type header" $ do+      let gbk = ["\xC4\xE3", "\xBA\xC3"]+      decodeFake [("content-type", "text/html; charset=GBK")] gbk `shouldReturn` ("你好" :: T.Text)+      decodeFake [("Content-Type", "text/html; boundary=x; Charset=\"gbk\"")] gbk `shouldReturn` ("你好" :: String)+      decodeFake [("Content-Type", "text/plain; charset=ISO-8859-1")] ["caf\xE9"] `shouldReturn` ("café" :: T.Text)++    it "should decode text as UTF-8 when the charset is missing or unknown" $ do+      let utf8 = [T.encodeUtf8 "你好"]+      decodeFake [] utf8 `shouldReturn` ("你好" :: T.Text)+      decodeFake [("Content-Type", "text/html")] utf8 `shouldReturn` ("你好" :: T.Text)+      decodeFake [("Content-Type", "text/html; charset=no-such-charset")] utf8 `shouldReturn` ("你好" :: T.Text)++    it "should replace invalid input instead of failing" $ do+      decodeFake [("Content-Type", "text/html; charset=GBK")] ["a\xFF"] `shouldReturn` ("a\xFFFD" :: T.Text)++    it "should join chunks and close the stream for buffered bodies" $ do+      (res, closed) <- fakeResponse [] ["{\"uuid\":", "\"abc\"}"]+      decoded <- fromResponse res+      uuid decoded `shouldBe` "abc"+      readIORef closed `shouldReturn` True++    it "should throw AesonException and close the stream when JSON decoding fails" $ do+      (res, closed) <- fakeResponse [] ["<html>"]+      (fromResponse res :: IO UUID) `shouldThrow` \(AesonException _) -> True+      readIORef closed `shouldReturn` True++    it "should throw ResponseBodyException when decodeResponse fails" $ do+      (res, closed) <- fakeResponse [] ["oops"]+      let decode r = if responseStatus r == 200 then Left "bad body" else Right ()+      decodeResponse decode res `shouldThrow` \(ResponseBodyException msg) -> msg == "bad body"+      readIORef closed `shouldReturn` True++    it "should leave the stream open for streaming bodies" $ do+      (res, closed) <- fakeResponse [] ["data: a\n\nda", "ta: b\n\n"]+      events <- fromResponse res :: IO (StreamBody SseEvent)+      events.readNext `shouldReturn` Just (SseEvent "a" Nothing Nothing)+      events.readNext `shouldReturn` Just (SseEvent "b" Nothing Nothing)+      events.readNext `shouldReturn` Nothing+      readIORef closed `shouldReturn` False+      events.closeStream+      readIORef closed `shouldReturn` True++    it "should buffer the body as strict and lazy ByteString" $ do+      decodeFake [] ["ab", "cd"] `shouldReturn` ("abcd" :: BS.ByteString)+      decodeFake [] ["ab", "cd"] `shouldReturn` ("abcd" :: LBS.ByteString)++    it "should drain and close the stream for a unit body" $ do+      (res, closed) <- fakeResponse [] ["ignored"]+      fromResponse res `shouldReturn` ()+      readIORef closed `shouldReturn` True++  describe "ToRequestBody" $ do+    it "should send ByteString bodies as application/octet-stream" $ do+      toRequestBody ("raw" :: BS.ByteString) `shouldBe` "raw"+      requestContentType ("raw" :: BS.ByteString) `shouldBe` Just "application/octet-stream"+      toRequestBody ("raw" :: LBS.ByteString) `shouldBe` "raw"+      requestContentType ("raw" :: LBS.ByteString) `shouldBe` Just "application/octet-stream"++    it "should encode text bodies as UTF-8 text/plain" $ do+      toRequestBody ("你好" :: T.Text) `shouldBe` T.encodeUtf8 "你好"+      requestContentType ("你好" :: T.Text) `shouldBe` Just "text/plain; charset=utf-8"+      toRequestBody ("你好" :: String) `shouldBe` T.encodeUtf8 "你好"+      requestContentType ("你好" :: String) `shouldBe` Just "text/plain; charset=utf-8"++    it "should encode ToJSON values as application/json" $ do+      toRequestBody (Greeting "Hello!") `shouldBe` "{\"message\":\"Hello!\"}"+      requestContentType (Greeting "Hello!") `shouldBe` Just "application/json"++    it "should send an empty body without Content-Type for unit" $ do+      toRequestBody () `shouldBe` ""+      requestContentType () `shouldBe` Nothing++    it "should url-encode forms from a list and from a ToForm instance" $ do+      toRequestBody (Form [("q", "hello world"), ("lang", "zh-CN")]) `shouldBe` "q=hello%20world&lang=zh-CN"+      toRequestBody (Form (Login "alice" "s3cret")) `shouldBe` "username=alice&password=s3cret"+      requestContentType (Form (Login "alice" "s3cret")) `shouldBe` Just "application/x-www-form-urlencoded"++  describe "sendWith" $ do+    let userAgent = "User-Agent: haskell-request/" <> VERSION_request :: BS.ByteString++    it "should write the request and decode the response" $ do+      (mgr, sent) <- fakeManager okResponse+      response <- sendWith mgr (Request POST "http://example.test/post?x=1" [("X-Test", "1")] (Greeting "Hello!")) :: IO (Response UUID)+      response.status `shouldBe` 200+      lookup "Content-Type" response.headers `shouldBe` Just "application/json"+      uuid response.body `shouldBe` "abc"+      request <- readIORef sent+      request `shouldSatisfy` BS.isPrefixOf "POST /post?x=1 HTTP/1.1\r\n"+      request `shouldSatisfy` BS.isInfixOf "Host: example.test\r\n"+      request `shouldSatisfy` BS.isInfixOf "X-Test: 1\r\n"+      request `shouldSatisfy` BS.isSuffixOf "\r\n\r\n{\"message\":\"Hello!\"}"++    it "should add default User-Agent and Content-Type headers" $ do+      (mgr, sent) <- fakeManager okResponse+      _ <- sendWith mgr (Request POST "http://example.test/" [] (Greeting "Hello!")) :: IO (Response ())+      request <- readIORef sent+      request `shouldSatisfy` BS.isInfixOf (userAgent <> "\r\n")+      request `shouldSatisfy` BS.isInfixOf "Content-Type: application/json\r\n"++    it "should not override user provided User-Agent and Content-Type headers" $ do+      (mgr, sent) <- fakeManager okResponse+      let hdrs = [("user-agent", "custom-agent"), ("content-type", "text/x-custom")]+      _ <- sendWith mgr (Request POST "http://example.test/" hdrs (Greeting "Hello!")) :: IO (Response ())+      request <- readIORef sent+      request `shouldSatisfy` BS.isInfixOf "user-agent: custom-agent\r\n"+      request `shouldSatisfy` BS.isInfixOf "content-type: text/x-custom\r\n"+      request `shouldSatisfy` not . BS.isInfixOf userAgent+      request `shouldSatisfy` not . BS.isInfixOf "application/json"++    it "should send credentials from the URL unless Authorization is provided" $ do+      (mgr, sent) <- fakeManager okResponse+      _ <- sendWith mgr (Request GET "http://alice:s3cret@example.test/" [] ()) :: IO (Response ())+      readIORef sent >>= (`shouldSatisfy` BS.isInfixOf "Authorization: Basic YWxpY2U6czNjcmV0\r\n")+      (mgr', sent') <- fakeManager okResponse+      _ <- sendWith mgr' (Request GET "http://alice:s3cret@example.test/" [("authorization", "Bearer my-token")] ()) :: IO (Response ())+      request <- readIORef sent'+      request `shouldSatisfy` BS.isInfixOf "authorization: Bearer my-token\r\n"+      request `shouldSatisfy` not . BS.isInfixOf "Basic YWxpY2U6czNjcmV0"++    it "should return error statuses for raiseForStatus to throw" $ do+      (mgr, _) <- fakeManager "HTTP/1.1 404 Not Found\r\nContent-Length: 9\r\n\r\nnot found"+      response <- sendWith mgr (Request GET "http://example.test/missing" [] ()) :: IO (Response String)+      response.status `shouldBe` 404+      response.body `shouldBe` "not found"+      raiseForStatus response `shouldThrow` \(StatusException code _) -> code == 404++  describe "addQuery" $ do+    it "should append parameters to a URL without a query" $ do+      addQuery "https://example.com/search" [("q", "haskell"), ("page", "2")]+        `shouldBe` "https://example.com/search?q=haskell&page=2"++    it "should keep parameters already in the URL" $ do+      addQuery "https://example.com/search?q=haskell" [("page", "2")]+        `shouldBe` "https://example.com/search?q=haskell&page=2"+      addQuery "https://example.com/search?" [("page", "2")]+        `shouldBe` "https://example.com/search?page=2"+      addQuery "https://example.com/search?q=haskell&" [("page", "2")]+        `shouldBe` "https://example.com/search?q=haskell&page=2"++    it "should keep the fragment at the end" $ do+      addQuery "https://example.com/doc#intro" [("v", "1")]+        `shouldBe` "https://example.com/doc?v=1#intro"+      addQuery "https://example.com/doc?a=1#intro" [("v", "1")]+        `shouldBe` "https://example.com/doc?a=1&v=1#intro"++    it "should escape reserved and non-ASCII characters" $ do+      addQuery "https://example.com/" [("q", "a b&c=d"), ("\20013\25991", "\20320\22909")]+        `shouldBe` "https://example.com/?q=a%20b%26c%3Dd&%E4%B8%AD%E6%96%87=%E4%BD%A0%E5%A5%BD"++    it "should leave the URL untouched when there are no parameters" $ do+      addQuery "https://example.com/search" [] `shouldBe` "https://example.com/search"++    it "should produce a URL that reaches the wire" $ do+      (manager, sentRef) <- fakeManager "HTTP/1.1 200 OK\r\nContent-Length: 0\r\n\r\n"+      _ <- sendWith manager (Request GET (addQuery "http://example.com/search" [("q", "a b")]) [] ()) :: IO (Response BS.ByteString)+      sent <- readIORef sentRef+      BS.isPrefixOf "GET /search?q=a%20b HTTP/1.1" sent `shouldBe` True+   describe "Network.HTTP.Request" $ do     let defaultUserAgent = "haskell-request/" <> VERSION_request @@ -114,6 +340,11 @@       responseStatus response `shouldBe` 200       responseBody response `shouldSatisfy` isInfixOf "application/json" +    it "should post ByteString body as application/octet-stream" $ do+      response <- post "https://postman-echo.com/post" ("Hello!" :: BS.ByteString) :: IO (Response String)+      responseStatus response `shouldBe` 200+      responseBody response `shouldSatisfy` isInfixOf "application/octet-stream"+     it "should post url-encoded form from a list" $ do       response <- post "https://postman-echo.com/post" (Form [("foo", "bar"), ("baz", "qux")]) :: IO (Response String)       responseStatus response `shouldBe` 200@@ -146,13 +377,52 @@       responseBody response `shouldSatisfy` isInfixOf customUserAgent       responseBody response `shouldSatisfy` not . isInfixOf defaultUserAgent -    it "should add a Basic Authorization header" $ do-      let req = basicAuth "alice" "s3cret" (Request GET "http://example.com" [] ())-      requestHeaders req `shouldBe` [("Authorization", "Basic YWxpY2U6czNjcmV0")]+    it "should build a Basic Authorization header value" $ do+      basicAuth "alice" "s3cret" `shouldBe` "Basic YWxpY2U6czNjcmV0" -    it "should replace an existing Authorization header with a bearer token" $ do-      let req = bearerAuth "new-token" (Request GET "http://example.com" [("authorization", "old-token")] ())-      requestHeaders req `shouldBe` [("Authorization", "Bearer new-token")]+    it "should send credentials from the URL as Basic Authorization" $ do+      response <- get "https://alice:s3cret@postman-echo.com/get" :: IO (Response String)+      responseStatus response `shouldBe` 200+      responseBody response `shouldSatisfy` isInfixOf "Basic YWxpY2U6czNjcmV0"++    it "should prefer a user provided Authorization header over URL credentials" $ do+      let req = Request GET "https://alice:s3cret@postman-echo.com/get" [("authorization", "Bearer my-token")] ()+      response <- send req :: IO (Response String)+      responseStatus response `shouldBe` 200+      responseBody response `shouldSatisfy` isInfixOf "Bearer my-token"+      responseBody response `shouldSatisfy` not . isInfixOf "Basic YWxpY2U6czNjcmV0"++    it "should ignore the response body when the response type is unit" $ do+      response <- get "http://example.com" :: IO (Response ())+      responseStatus response `shouldBe` 200+      responseBody response `shouldBe` ()++    it "should return the response unchanged when raiseForStatus sees a 2xx status" $ do+      let resp = Response { status = 200, headers = [("X-Test", "1")], body = "ok" :: String }+      checked <- raiseForStatus resp+      checked.status `shouldBe` 200+      checked.body `shouldBe` "ok"++    it "should throw StatusException from raiseForStatus on a 4xx status" $ do+      let resp = Response { status = 404, headers = [("X-Test", "1")], body = () }+      raiseForStatus resp `shouldThrow` \(StatusException code hdrs) ->+        code == 404 && hdrs == [("X-Test", "1")]++    it "should throw StatusException for an error status from a real server" $ do+      let sendAndRaise = do+            resp <- get "https://postman-echo.com/status/500" :: IO (Response String)+            raiseForStatus resp+      sendAndRaise `shouldThrow` \(StatusException code _) -> code == 500++    it "should throw HttpException when the connection fails" $ do+      (get "http://localhost:1" :: IO (Response String)) `shouldThrow` \case+        HttpExceptionRequest _ (ConnectionFailure _) -> True+        _ -> False++    it "should throw HttpException for an invalid URL" $ do+      (get "not a url" :: IO (Response String)) `shouldThrow` \case+        InvalidUrlException _ _ -> True+        _ -> False      it "should send with a user-provided manager" $ do       mgr <- newManager