request 0.4.1.0 → 0.4.2.0

raw patch · 9 files changed

+618/−324 lines, 9 filesdep +base64-bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base64-bytestring

API changes (from Hackage documentation)

Files

• README.md +88/−11
• request.cabal +7/−1
• src/Network/HTTP/Request.hs +40/−304
• src/Network/HTTP/Request/Internal/Auth.hs +35/−0
• src/Network/HTTP/Request/Internal/Body.hs +160/−0
• src/Network/HTTP/Request/Internal/Client.hs +94/−0
• src/Network/HTTP/Request/Internal/Sse.hs +65/−0
• src/Network/HTTP/Request/Internal/Types.hs +86/−0
• test/Spec.hs +43/−8

@@ -26,11 +26,11 @@ import qualified Data.ByteString as BS  -- Using shortcuts-resp <- get "https://api.leancloud.cn/1.1/date"+resp <- get "https://httpbin.org/uuid" :: IO (Response String) print resp.status        -- 200  -- Or construct a Request manually-let req = Request { method = GET, url = "https://api.leancloud.cn/1.1/date", headers = [], body = () }+let req = Request { method = GET, url = "https://httpbin.org/uuid", headers = [], body = () }  -- Response with ByteString body responseBS <- send req :: IO (Response BS.ByteString)@@ -64,6 +64,7 @@ - `()` → empty body, no Content-Type - `ByteString` / lazy `ByteString` / `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`  The `Content-Type` is automatically inferred from the body type. You can override it by setting the header manually: @@ -110,18 +111,17 @@ import Data.Aeson (FromJSON) import GHC.Generics (Generic) -data Date = Date-  { __type :: String-  , iso :: String+data UUID = UUID+  { uuid :: String   } deriving (Show, Generic) -instance FromJSON Date+instance FromJSON UUID  main :: IO () main = do-  response <- get "https://api.leancloud.cn/1.1/date" :: IO (Response Date)+  response <- get "https://httpbin.org/uuid" :: IO (Response UUID)   print response.status  -- 200-  print response.body    -- Date { __type = "Date", iso = "..." }+  print response.body    -- UUID { uuid = "550e8400-e29b-41d4-a716-446655440000" } ```  If JSON decoding fails, an `AesonException` will be thrown, which can be caught with `Control.Exception.catch` or `try`.@@ -147,6 +147,70 @@   print response.status  -- 200 ``` +## Form Support++For `application/x-www-form-urlencoded` requests (login forms, OAuth token endpoints, classic web APIs), wrap your body in the `Form` newtype. The `Content-Type` is set automatically and values are percent-encoded.++### From a list of pairs++```haskell+import Network.HTTP.Request++main :: IO ()+main = do+  response <- post "https://httpbin.org/post"+                   (Form [("username", "alice"), ("password", "s3cret")])+              :: IO (Response String)+  print response.status  -- 200+  -- Body sent: username=alice&password=s3cret+```++Values are `ByteString` keys and values. Special characters (spaces, Unicode, reserved chars) are percent-encoded for you:++```haskell+post "https://api.example.com/search"+     (Form [("q", "hello world"), ("lang", "zh-CN")])+-- Body sent: q=hello%20world&lang=zh-CN+```++### From a custom type++For your own record types, define a `ToForm` instance. This mirrors the `ToJSON` pattern:++```haskell+import Network.HTTP.Request+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++data Login = Login+  { username :: T.Text+  , password :: T.Text+  }++instance ToForm Login where+  toForm l = [ ("username", T.encodeUtf8 l.username)+             , ("password", T.encodeUtf8 l.password)+             ]++main :: IO ()+main = do+  response <- post "https://api.example.com/login"+                   (Form (Login "alice" "s3cret"))+              :: IO (Response String)+  print response.status+```++### The two new pieces of API++```haskell+class ToForm a where+  toForm :: a -> [(ByteString, ByteString)]++newtype Form a = Form a+```++The `Form` newtype is required to disambiguate the form-encoding path from JSON. Without it, a type that has both `ToJSON` and `ToForm` instances would be ambiguous; with it, `post url x` always means JSON and `post url (Form x)` always means form.+ ## Shortcuts  As you expected, there are some shortcuts for the most used scenarios.@@ -161,6 +225,20 @@  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. +## Authentication++Use `basicAuth` or `bearerAuth` to add an `Authorization` header to a request:++```haskell+let basicReq = basicAuth "username" "password" (Request GET url [] ())+basicResponse <- send basicReq :: IO (Response String)++let bearerReq = bearerAuth "token" (Request GET url [] ())+bearerResponse <- send bearerReq :: IO (Response String)+```++Both helpers replace an existing `Authorization` header, regardless of the header name's casing.+ ## Without Language Extensions  If you prefer not to use the language extensions, you can still use the library with the traditional syntax:@@ -170,12 +248,11 @@  ```haskell import Network.HTTP.Request-import qualified Data.ByteString as BS  -- Construct a Request using positional arguments-let req = Request GET "https://api.leancloud.cn/1.1/date" [] ()+let req = Request GET "https://httpbin.org/uuid" [] () -- Send it-res <- send req+res <- send req :: IO (Response String) -- Access the fields using prefixed accessor functions print $ responseStatus res ```

@@ -1,5 +1,5 @@ name:                request-version:             0.4.1.0+version:             0.4.2.0 -- synopsis: description:         "HTTP client for haskell, inpired by requests and http-dispatch." homepage:            https://github.com/aisk/request#readme@@ -16,8 +16,14 @@ library   hs-source-dirs:      src   exposed-modules:     Network.HTTP.Request+  other-modules:       Network.HTTP.Request.Internal.Auth+                     , Network.HTTP.Request.Internal.Body+                     , Network.HTTP.Request.Internal.Client+                     , Network.HTTP.Request.Internal.Sse+                     , Network.HTTP.Request.Internal.Types   build-depends:       base               >= 4.7 && < 5                      , aeson              >= 2.0 && < 2.3+                     , base64-bytestring  >= 1.2 && < 1.3                      , bytestring         >= 0.10.12 && < 0.13                      , case-insensitive   >= 1.2.1 && < 1.3                      , http-client        >= 0.6.4 && < 0.8

@@ -1,22 +1,21 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedRecordDot #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE UndecidableInstances #-}  module Network.HTTP.Request   ( Header,     Headers,     FromResponseBody (..),     ToRequestBody (..),+    ToForm (..),+    Form (..),     Manager,     Method (..),     Request (..),     Response (..),+    ResponseBodyException (..),     StreamBody (..),     SseEvent (..),+    basicAuth,+    bearerAuth,     get,     delete,     patch,@@ -35,301 +34,38 @@   ) where -import Control.Exception (throwIO)-import Data.Aeson (AesonException (..), FromJSON, ToJSON, eitherDecode, encode)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as C-import qualified Data.ByteString.Lazy as LBS-import qualified Data.CaseInsensitive as CI-import Data.IORef (modifyIORef, newIORef, readIORef, writeIORef)-import Data.Maybe (listToMaybe, mapMaybe)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Network.HTTP.Client (Manager)-import qualified Network.HTTP.Client as LowLevelClient-import qualified Network.HTTP.Client.TLS as LowLevelTLSClient-import qualified Network.HTTP.Types.Status as LowLevelStatus--type Header = (BS.ByteString, BS.ByteString)--type Headers = [Header]--class FromResponseBody a where-  fromResponseBody :: LBS.ByteString -> Either String 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 (AesonException err)--instance FromResponseBody BS.ByteString where-  fromResponseBody = Right . LBS.toStrict--instance FromResponseBody LBS.ByteString where-  fromResponseBody = Right--instance FromResponseBody T.Text where-  fromResponseBody = Right . T.decodeUtf8Lenient . LBS.toStrict--instance FromResponseBody String where-  fromResponseBody = Right . T.unpack . T.decodeUtf8Lenient . LBS.toStrict--instance {-# OVERLAPPABLE #-} (FromJSON a) => FromResponseBody a where-  fromResponseBody = eitherDecode--data StreamBody a = StreamBody-  { readNext :: IO (Maybe a),-    closeStream :: IO ()-  }--data SseEvent = SseEvent-  { sseData :: T.Text,-    sseType :: Maybe T.Text,-    sseId :: Maybe T.Text-  }-  deriving (Show)--findEventSep :: BS.ByteString -> Maybe (Int, Int)-findEventSep bs =-  foldr-    earlier-    Nothing-    [ tryFind "\r\n\r\n" 4,-      tryFind "\n\n" 2,-      tryFind "\r\r" 2-    ]-  where-    tryFind pat sepLen =-      let (h, t) = BS.breakSubstring pat bs-       in if BS.null t then Nothing else Just (BS.length h, BS.length h + sepLen)-    earlier a Nothing = a-    earlier Nothing b = b-    earlier a@(Just (s1, _)) b@(Just (s2, _)) = if s1 <= s2 then a else b--parseSseField :: T.Text -> Maybe (T.Text, T.Text)-parseSseField line-  | T.null line = Nothing-  | T.head line == ':' = Nothing-  | otherwise =-      let (name, rest) = T.breakOn ":" line-          value-            | T.null rest = ""-            | otherwise = case T.stripPrefix " " (T.drop 1 rest) of-                Just v -> v-                Nothing -> T.drop 1 rest-       in Just (name, value)--parseSseBlock :: BS.ByteString -> 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-      dataVal = T.intercalate "\n" [v | (k, v) <- fields, k == "data"]-      typeVal = listToMaybe [v | (k, v) <- fields, k == "event"]-      idVal = listToMaybe [v | (k, v) <- fields, k == "id"]-   in SseEvent dataVal typeVal idVal--instance FromResponseBody (StreamBody BS.ByteString) where-  fromResponseBody _ = Left "StreamBody must be built via buildResponse"--  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 FromResponseBody (StreamBody SseEvent) where-  fromResponseBody _ = Left "StreamBody must be built via buildResponse"--  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)-              return $ Just (parseSseBlock (BS.take blockEnd buf))-            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 $ Just (parseSseBlock buf)-                else do-                  modifyIORef bufRef (<> chunk)-                  readNext-    return $ Response status hdrs (StreamBody readNext (LowLevelClient.responseClose llres))--class ToRequestBody a where-  toRequestBody :: a -> BS.ByteString-  requestContentType :: a -> Maybe BS.ByteString-  requestContentType _ = Nothing--instance ToRequestBody BS.ByteString where-  toRequestBody = id-  requestContentType _ = Just "text/plain; charset=utf-8"--instance ToRequestBody LBS.ByteString where-  toRequestBody = LBS.toStrict-  requestContentType _ = Just "text/plain; charset=utf-8"--instance ToRequestBody T.Text where-  toRequestBody = T.encodeUtf8-  requestContentType _ = Just "text/plain; charset=utf-8"--instance ToRequestBody String where-  toRequestBody = T.encodeUtf8 . T.pack-  requestContentType _ = Just "text/plain; charset=utf-8"--instance {-# OVERLAPPABLE #-} (ToJSON a) => ToRequestBody a where-  toRequestBody = LBS.toStrict . encode-  requestContentType _ = Just "application/json"--instance ToRequestBody () where-  toRequestBody () = BS.empty-  requestContentType () = Nothing--data Method-  = DELETE-  | GET-  | HEAD-  | OPTIONS-  | PATCH-  | POST-  | PUT-  | TRACE-  | Method String-  deriving (Show, Eq)--methodToByteString :: Method -> BS.ByteString-methodToByteString DELETE = "DELETE"-methodToByteString GET = "GET"-methodToByteString HEAD = "HEAD"-methodToByteString OPTIONS = "OPTIONS"-methodToByteString PATCH = "PATCH"-methodToByteString POST = "POST"-methodToByteString PUT = "PUT"-methodToByteString TRACE = "TRACE"-methodToByteString (Method m) = C.pack m--data Request a = Request-  { method :: Method,-    url :: String,-    headers :: Headers,-    body :: a-  }-  deriving (Show)---- Compatibility accessor functions-requestMethod :: Request a -> Method-requestMethod req = req.method--requestUrl :: Request a -> String-requestUrl req = req.url--requestHeaders :: Request a -> Headers-requestHeaders req = req.headers--requestBody :: Request a -> a-requestBody req = req.body--toLowlevelRequest :: (ToRequestBody a) => Request a -> IO LowLevelClient.Request-toLowlevelRequest req = do-  initReq <- LowLevelClient.parseRequest req.url-  let autoContentType = requestContentType req.body-      hasContentType = any (\(k, _) -> k == "Content-Type") req.headers-      hasUserAgent = any (\(k, _) -> CI.mk k == CI.mk ("User-Agent" :: BS.ByteString)) req.headers-      defaultUserAgent = C.pack $ "haskell-request/" <> VERSION_request-      extraContentType =-        maybe [] (\c -> [("Content-Type", c)]) $-          if hasContentType then Nothing else autoContentType-      extraUserAgent =-        if hasUserAgent-          then []-          else [("User-Agent", defaultUserAgent)]-  return $-    initReq-      { LowLevelClient.method = methodToByteString req.method,-        LowLevelClient.requestHeaders = map (\(k, v) -> (CI.mk k, v)) (req.headers ++ extraContentType ++ extraUserAgent),-        LowLevelClient.requestBody = LowLevelClient.RequestBodyBS (toRequestBody req.body)-      }--data Response a = Response-  { status :: Int,-    headers :: Headers,-    body :: a-  }-  deriving (Show)---- Compatibility accessor functions for Response-responseStatus :: Response a -> Int-responseStatus res = res.status--responseHeaders :: Response a -> Headers-responseHeaders res = res.headers--responseBody :: Response a -> a-responseBody res = res.body--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) ->-                      let hk = CI.original k-                       in (hk, v)-                  )-                  headers-              )-              body-        Left err -> Left err--newManager :: IO Manager-newManager = LowLevelTLSClient.newTlsManager--sendWith :: (ToRequestBody a, FromResponseBody b) => Manager -> Request a -> IO (Response b)-sendWith manager req = do-  llreq <- toLowlevelRequest req-  buildResponse llreq manager--send :: (ToRequestBody a, FromResponseBody b) => Request a -> IO (Response b)-send req = do-  manager <- LowLevelTLSClient.getGlobalManager-  sendWith manager req--get :: (FromResponseBody a) => String -> IO (Response a)-get url =-  send $ Request GET url [] ()--delete :: (FromResponseBody a) => String -> IO (Response a)-delete url =-  send $ Request DELETE url [] ()--post :: (ToRequestBody a, FromResponseBody 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 url body =-  send $ Request PUT url [] body--patch :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b)-patch url body =-  send $ Request PATCH url [] body+import Network.HTTP.Request.Internal.Auth (basicAuth, bearerAuth)+import Network.HTTP.Request.Internal.Body+  ( Form (..),+    FromResponseBody (..),+    ResponseBodyException (..),+    ToForm (..),+    ToRequestBody (..),+  )+import Network.HTTP.Request.Internal.Client+  ( Manager,+    delete,+    get,+    newManager,+    patch,+    post,+    put,+    send,+    sendWith,+  )+import Network.HTTP.Request.Internal.Types+  ( Header,+    Headers,+    Method (..),+    Request (..),+    Response (..),+    SseEvent (..),+    StreamBody (..),+    requestBody,+    requestHeaders,+    requestMethod,+    requestUrl,+    responseBody,+    responseHeaders,+    responseStatus,+  )

@@ -0,0 +1,35 @@+{-# LANGUAGE OverloadedStrings #-}++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)

@@ -0,0 +1,160 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Network.HTTP.Request.Internal.Body+  ( FromResponseBody (..),+    ToRequestBody (..),+    ToForm (..),+    Form (..),+    ResponseBodyException (..),+  )+where++import Control.Exception (Exception, SomeException, throwIO, toException)+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 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.Types.URI (renderSimpleQuery)++newtype ResponseBodyException = ResponseBodyException String+  deriving (Show)++instance Exception ResponseBodyException++class FromResponseBody a where+  fromResponseBody :: LBS.ByteString -> Either String a++  responseBodyException :: proxy a -> String -> SomeException+  responseBodyException _ = toException . ResponseBodyException++  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)++instance FromResponseBody BS.ByteString where+  fromResponseBody = Right . LBS.toStrict++instance FromResponseBody LBS.ByteString where+  fromResponseBody = Right++instance FromResponseBody T.Text where+  fromResponseBody = Right . T.decodeUtf8Lenient . LBS.toStrict++instance FromResponseBody String where+  fromResponseBody = Right . T.unpack . T.decodeUtf8Lenient . LBS.toStrict++instance {-# OVERLAPPABLE #-} (FromJSON a) => FromResponseBody a where+  fromResponseBody = eitherDecode+  responseBodyException _ = toException . AesonException++instance FromResponseBody (StreamBody BS.ByteString) where+  fromResponseBody _ = Left "StreamBody must be built via buildResponse"++  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 FromResponseBody (StreamBody SseEvent) where+  fromResponseBody _ = Left "StreamBody must be built via buildResponse"++  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))++class ToRequestBody a where+  toRequestBody :: a -> BS.ByteString+  requestContentType :: a -> Maybe BS.ByteString+  requestContentType _ = Nothing++instance ToRequestBody BS.ByteString where+  toRequestBody = id+  requestContentType _ = Just "text/plain; charset=utf-8"++instance ToRequestBody LBS.ByteString where+  toRequestBody = LBS.toStrict+  requestContentType _ = Just "text/plain; charset=utf-8"++instance ToRequestBody T.Text where+  toRequestBody = T.encodeUtf8+  requestContentType _ = Just "text/plain; charset=utf-8"++instance ToRequestBody String where+  toRequestBody = T.encodeUtf8 . T.pack+  requestContentType _ = Just "text/plain; charset=utf-8"++instance {-# OVERLAPPABLE #-} (ToJSON a) => ToRequestBody a where+  toRequestBody = LBS.toStrict . encode+  requestContentType _ = Just "application/json"++instance ToRequestBody () where+  toRequestBody () = BS.empty+  requestContentType () = Nothing++class ToForm a where+  toForm :: a -> [(BS.ByteString, BS.ByteString)]++instance (k ~ BS.ByteString, v ~ BS.ByteString) => ToForm [(k, v)] where+  toForm = id++newtype Form a = Form a++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,94 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Request.Internal.Client+  ( Manager,+    newManager,+    send,+    sendWith,+    get,+    delete,+    patch,+    post,+    put,+  )+where++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.Types+  ( Method (..),+    Request (..),+    Response,+    requestBody,+    requestHeaders,+    requestMethod,+    requestUrl,+  )++methodToByteString :: Method -> BS.ByteString+methodToByteString DELETE = "DELETE"+methodToByteString GET = "GET"+methodToByteString HEAD = "HEAD"+methodToByteString OPTIONS = "OPTIONS"+methodToByteString PATCH = "PATCH"+methodToByteString POST = "POST"+methodToByteString PUT = "PUT"+methodToByteString TRACE = "TRACE"+methodToByteString (Method m) = C.pack m++toLowlevelRequest :: (ToRequestBody a) => Request a -> IO LowLevelClient.Request+toLowlevelRequest req = do+  initReq <- LowLevelClient.parseRequest (requestUrl req)+  let body = requestBody req+      headers = requestHeaders req+      autoContentType = requestContentType body+      hasContentType = any (\(k, _) -> CI.mk k == CI.mk ("Content-Type" :: BS.ByteString)) headers+      hasUserAgent = any (\(k, _) -> CI.mk k == CI.mk ("User-Agent" :: BS.ByteString)) headers+      defaultUserAgent = C.pack $ "haskell-request/" <> VERSION_request+      extraContentType =+        maybe [] (\c -> [("Content-Type", c)]) $+          if hasContentType then Nothing else autoContentType+      extraUserAgent =+        if hasUserAgent+          then []+          else [("User-Agent", defaultUserAgent)]+  return $+    initReq+      { LowLevelClient.method = methodToByteString (requestMethod req),+        LowLevelClient.requestHeaders = map (\(k, v) -> (CI.mk k, v)) (headers ++ extraContentType ++ extraUserAgent),+        LowLevelClient.requestBody = LowLevelClient.RequestBodyBS (toRequestBody body)+      }++newManager :: IO Manager+newManager = LowLevelTLSClient.newTlsManager++sendWith :: (ToRequestBody a, FromResponseBody b) => Manager -> Request a -> IO (Response b)+sendWith manager req = do+  llreq <- toLowlevelRequest req+  buildResponse llreq manager++send :: (ToRequestBody a, FromResponseBody b) => Request a -> IO (Response b)+send req = do+  manager <- LowLevelTLSClient.getGlobalManager+  sendWith manager req++get :: (FromResponseBody a) => String -> IO (Response a)+get url = send $ Request GET url [] ()++delete :: (FromResponseBody a) => String -> IO (Response a)+delete url = send $ Request DELETE url [] ()++post :: (ToRequestBody a, FromResponseBody 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 url body = send $ Request PUT url [] body++patch :: (ToRequestBody a, FromResponseBody b) => String -> a -> IO (Response b)+patch url body = send $ Request PATCH url [] body

@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Request.Internal.Sse+  ( findEventSep,+    parseSseBlock,+  )+where++import qualified Data.ByteString as BS+import Data.List (foldl')+import Data.Maybe (mapMaybe)+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"+    ]+  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++parseSseField :: T.Text -> Maybe (T.Text, T.Text)+parseSseField line+  | T.null line = Nothing+  | T.head line == ':' = Nothing+  | otherwise =+      let (name, rest) = T.breakOn ":" line+          value+            | T.null rest = ""+            | otherwise = case T.stripPrefix " " (T.drop 1 rest) of+                Just v -> v+                Nothing -> T.drop 1 rest+       in Just (name, value)++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"]+      dataVal = T.intercalate "\n" dataFields+      lastField name = foldl' (\current (k, v) -> if k == name then Just v else current) Nothing fields+      typeVal = lastField "event"+      idVal = lastField "id"+   in if null dataFields then Nothing else Just (SseEvent dataVal typeVal idVal)

@@ -0,0 +1,86 @@+{-# LANGUAGE DuplicateRecordFields #-}++module Network.HTTP.Request.Internal.Types+  ( Header,+    Headers,+    Method (..),+    Request (..),+    Response (..),+    StreamBody (..),+    SseEvent (..),+    requestMethod,+    requestUrl,+    requestHeaders,+    requestBody,+    responseStatus,+    responseHeaders,+    responseBody,+  )+where++import qualified Data.ByteString as BS+import qualified Data.Text as T++type Header = (BS.ByteString, BS.ByteString)++type Headers = [Header]++data Method+  = DELETE+  | GET+  | HEAD+  | OPTIONS+  | PATCH+  | POST+  | PUT+  | TRACE+  | Method String+  deriving (Show, Eq)++data Request a = Request+  { method :: Method,+    url :: String,+    headers :: Headers,+    body :: a+  }+  deriving (Show)++data Response a = Response+  { status :: Int,+    headers :: Headers,+    body :: a+  }+  deriving (Show)++data StreamBody a = StreamBody+  { readNext :: IO (Maybe a),+    closeStream :: IO ()+  }++data SseEvent = SseEvent+  { sseData :: T.Text,+    sseType :: Maybe T.Text,+    sseId :: Maybe T.Text+  }+  deriving (Show)++requestMethod :: Request a -> Method+requestMethod (Request value _ _ _) = value++requestUrl :: Request a -> String+requestUrl (Request _ value _ _) = value++requestHeaders :: Request a -> Headers+requestHeaders (Request _ _ value _) = value++requestBody :: Request a -> a+requestBody (Request _ _ _ value) = value++responseStatus :: Response a -> Int+responseStatus (Response value _ _) = value++responseHeaders :: Response a -> Headers+responseHeaders (Response _ value _) = value++responseBody :: Response a -> a+responseBody (Response _ _ value) = value

@@ -16,12 +16,11 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T -data Date = Date-  { __type :: String-  , iso :: String+data UUID = UUID+  { uuid :: String   } deriving (Show, Generic) -instance FromJSON Date+instance FromJSON UUID  data Greeting = Greeting   { message :: String@@ -29,6 +28,16 @@  instance ToJSON Greeting +data Login = Login+  { username :: T.Text+  , password :: T.Text+  } deriving (Show)++instance ToForm Login where+  toForm l = [ ("username", T.encodeUtf8 l.username)+             , ("password", T.encodeUtf8 l.password)+             ]+ main :: IO () main = hspec $ do   describe "Network.HTTP.Request" $ do@@ -96,16 +105,34 @@       responseBody response `shouldSatisfy` isInfixOf "🌍"      it "should parse JSON response with aeson" $ do-      response <- get "https://api.leancloud.cn/1.1/date" :: IO (Response Date)+      response <- get "https://httpbin.org/uuid" :: IO (Response UUID)       responseStatus response `shouldBe` 200-      __type (responseBody response) `shouldBe` "Date"-      iso (responseBody response) `shouldSatisfy` not . null+      uuid (responseBody response) `shouldSatisfy` not . null      it "should post JSON body with automatic Content-Type" $ do       response <- post "https://postman-echo.com/post" (Greeting "Hello!") :: IO (Response String)       responseStatus response `shouldBe` 200       responseBody response `shouldSatisfy` isInfixOf "application/json" +    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+      responseBody response `shouldSatisfy` isInfixOf "application/x-www-form-urlencoded"+      responseBody response `shouldSatisfy` isInfixOf "\"foo\":\"bar\""+      responseBody response `shouldSatisfy` isInfixOf "\"baz\":\"qux\""++    it "should post url-encoded form from a ToForm instance" $ do+      response <- post "https://postman-echo.com/post" (Form (Login "alice" "s3cret")) :: IO (Response String)+      responseStatus response `shouldBe` 200+      responseBody response `shouldSatisfy` isInfixOf "application/x-www-form-urlencoded"+      responseBody response `shouldSatisfy` isInfixOf "\"username\":\"alice\""+      responseBody response `shouldSatisfy` isInfixOf "\"password\":\"s3cret\""++    it "should percent-encode form values with special characters" $ do+      response <- post "https://postman-echo.com/post" (Form [("q", "hello world"), ("lang", "zh-CN")]) :: IO (Response String)+      responseStatus response `shouldBe` 200+      responseBody response `shouldSatisfy` isInfixOf "\"q\":\"hello world\""+     it "should add default User-Agent when request header is missing" $ do       response <- send (Request GET "https://postman-echo.com/get" [] ()) :: IO (Response String)       responseStatus response `shouldBe` 200@@ -119,6 +146,14 @@       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 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 with a user-provided manager" $ do       mgr <- newManager       response <- sendWith mgr (Request GET "http://example.com" [] ()) :: IO (Response String)@@ -133,7 +168,7 @@       mChunk `shouldSatisfy` (/= Nothing)      it "should parse and stream SSE events" $ do-      let req = Request GET "https://sse.dev/test" [] ()+      let req = Request GET "https://stream.wikimedia.org/v2/stream/recentchange" [] ()       resp <- send req :: IO (Response (StreamBody SseEvent))       resp.status `shouldBe` 200       mEvent <- resp.body.readNext