diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2017, AN Long + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,281 @@ +# request + +![](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). + +[![Ask DeepWiki](https://deepwiki.com/badge.svg)](https://deepwiki.com/aisk/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. + +## Usage + +This library supports modern Haskell record dot syntax. First, enable these language extensions: + +```haskell +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedRecordDot #-} +``` + +Then you can use the library like this: + +```haskell +import Network.HTTP.Request +import qualified Data.ByteString as BS + +-- Using shortcuts +resp <- get "https://api.leancloud.cn/1.1/date" +print resp.status -- 200 + +-- Or construct a Request manually +let req = Request { method = GET, url = "https://api.leancloud.cn/1.1/date", headers = [], body = () } + +-- Response with ByteString body +responseBS <- send req :: IO (Response BS.ByteString) +print responseBS.status -- 200 +print responseBS.body -- ByteString response + +-- Response with String body +responseStr <- send req :: IO (Response String) +print responseStr.body -- String response +``` + +## Core API + +Request's API has three core concepts: `Request` record type, `Response` record type, `send` function. + +### Request + +`Request a` is all about the information you will send to the target URL. The type parameter `a` is the body type, it can be any type that implements `ToRequestBody`. When `send` is called, the body is automatically serialized and the appropriate `Content-Type` header is inferred, unless you set it manually. + +```haskell +data Request a = Request + { method :: Method + , url :: String + , headers :: Headers + , body :: a + } deriving (Show) +``` + +Built-in `ToRequestBody` instances and their inferred `Content-Type`: + +- `()` → 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` + +The `Content-Type` is automatically inferred from the body type. You can override it by setting the header manually: + +```haskell +-- Content-Type is auto-inferred from body type +send $ Request POST url [] body + +-- Or override Content-Type manually +send $ Request POST url [("Content-Type", "text/xml")] xmlBytes +``` + +### Response + +`Response` is what you got from the server URL. + +```haskell +data Response a = Response + { status :: Int + , headers :: Headers + , body :: a + } 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. + +### 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) +``` + +## JSON Support + +### JSON Response + +For any type with a `FromJSON` instance, the response body will be automatically decoded: + +```haskell +{-# LANGUAGE DeriveGeneric #-} + +import Network.HTTP.Request +import Data.Aeson (FromJSON) +import GHC.Generics (Generic) + +data Date = Date + { __type :: String + , iso :: String + } deriving (Show, Generic) + +instance FromJSON Date + +main :: IO () +main = do + response <- get "https://api.leancloud.cn/1.1/date" :: IO (Response Date) + print response.status -- 200 + print response.body -- Date { __type = "Date", iso = "..." } +``` + +If JSON decoding fails, an `AesonException` will be thrown, which can be caught with `Control.Exception.catch` or `try`. + +### JSON Request Body + +The `post`, `put`, and `patch` shortcuts accept any type that implements `ToRequestBody`. For types with a `ToJSON` instance, the body is automatically JSON-encoded and `Content-Type: application/json` is set: + +```haskell +{-# LANGUAGE DeriveGeneric #-} + +import Network.HTTP.Request +import Data.Aeson (ToJSON) +import GHC.Generics (Generic) + +data User = User { name :: String } deriving (Show, Generic) + +instance ToJSON User + +main :: IO () +main = do + response <- post "https://httpbin.org/post" (User "Alice") :: IO (Response String) + print response.status -- 200 +``` + +## Shortcuts + +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) +``` + +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. + +## Without Language Extensions + +If you prefer not to use the language extensions, you can still use the library with the traditional syntax: + +- Create requests using positional arguments: `Request GET "url" [] ()` +- Use prefixed accessor functions: `responseStatus response`, `responseHeaders response`, etc. + +```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" [] () +-- Send it +res <- send req +-- Access the fields using prefixed accessor functions +print $ responseStatus res +``` + +## Custom Connection Manager + +By default, `send` uses the `http-client` global TLS manager. For most applications this is fine, you get connection pooling for free with no setup. If you want to isolate your library's connection pool from the rest of the program, keep a long-lived manager in a service, or configure proxies and custom TLS settings, create your own manager and pass it to `sendWith`: + +```haskell +import Network.HTTP.Request + +main :: IO () +main = do + mgr <- newManager + resp <- sendWith mgr (Request GET "https://api.example.com/things" [] ()) :: IO (Response String) + print resp.status +``` + +The two new pieces of API: + +```haskell +newManager :: IO Manager +sendWith :: (ToRequestBody a, FromResponseBody 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. + +## Streaming Support + +For large responses or real-time data, you can stream the response body instead of buffering it all in memory. + +### Raw Byte Chunks + +Use `StreamBody BS.ByteString` to receive the response body as a stream of raw byte chunks: + +```haskell +import Network.HTTP.Request +import qualified Data.ByteString as BS + +main :: IO () +main = do + let req = Request GET "https://example.com/large-file" [] () + resp <- send req :: IO (Response (StreamBody BS.ByteString)) + print resp.status -- 200 + + let loop = do + mChunk <- resp.body.readNext + case mChunk of + Nothing -> return () -- stream finished + Just chunk -> do + BS.putStr chunk + loop + loop + resp.body.closeStream +``` + +### SSE (Server-Sent Events) + +Use `StreamBody SseEvent` to automatically parse an SSE stream. Each call to `readNext` returns the next complete event: + +```haskell +import Network.HTTP.Request +import qualified Data.Text.IO as T + +data SseEvent = SseEvent + { sseData :: T.Text -- content of the "data:" field + , sseType :: Maybe T.Text -- content of the "event:" field + , sseId :: Maybe T.Text -- content of the "id:" field + } + +main :: IO () +main = do + let req = Request GET "https://example.com/events" [] () + resp <- send req :: IO (Response (StreamBody SseEvent)) + print resp.status -- 200 + + let loop = do + mEvent <- resp.body.readNext + case mEvent of + Nothing -> return () -- stream finished + Just event -> do + T.putStrLn event.sseData + loop + loop + resp.body.closeStream +``` + +`StreamBody` has two fields: + +- `readNext :: IO (Maybe a)` — reads the next chunk or event; returns `Nothing` when the stream ends +- `closeStream :: IO ()` — closes the underlying connection + +## API Documents + +See the hackage page: http://hackage.haskell.org/package/request/docs/Network-HTTP-Request.html + +## About the Project + +Request is © 2020-2026 by [AN Long](https://github.com/aisk). + +### License + +Request is distributed by a [BSD license](https://github.com/aisk/request/tree/master/LICENSE). diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/request.cabal b/request.cabal new file mode 100644 --- /dev/null +++ b/request.cabal @@ -0,0 +1,43 @@ +name: request +version: 0.4.1.0 +-- synopsis: +description: "HTTP client for haskell, inpired by requests and http-dispatch." +homepage: https://github.com/aisk/request#readme +license: BSD3 +license-file: LICENSE +author: An Long +maintainer: aisk1988@gmail.com +copyright: 2020 AN Long +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Network.HTTP.Request + build-depends: base >= 4.7 && < 5 + , aeson >= 2.0 && < 2.3 + , bytestring >= 0.10.12 && < 0.13 + , case-insensitive >= 1.2.1 && < 1.3 + , 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 + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/aisk/request + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , request + , hspec + , bytestring >= 0.10.12 && < 0.13 + , text >= 1.2.4 && < 2.2 + , aeson + default-language: Haskell2010 diff --git a/src/Network/HTTP/Request.hs b/src/Network/HTTP/Request.hs new file mode 100644 --- /dev/null +++ b/src/Network/HTTP/Request.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +module Network.HTTP.Request + ( Header, + Headers, + FromResponseBody (..), + ToRequestBody (..), + Manager, + Method (..), + Request (..), + Response (..), + StreamBody (..), + SseEvent (..), + get, + delete, + patch, + post, + put, + newManager, + send, + sendWith, + requestMethod, + requestUrl, + requestHeaders, + requestBody, + responseStatus, + responseHeaders, + responseBody, + ) +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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.Aeson (FromJSON, ToJSON) +import Data.List (isInfixOf) +import GHC.Generics (Generic) +import Network.HTTP.Request +import Test.Hspec +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +data Date = Date + { __type :: String + , iso :: String + } deriving (Show, Generic) + +instance FromJSON Date + +data Greeting = Greeting + { message :: String + } deriving (Show, Generic) + +instance ToJSON Greeting + +main :: IO () +main = hspec $ do + describe "Network.HTTP.Request" $ do + let defaultUserAgent = "haskell-request/" <> VERSION_request + + it "should fetch example.com and return 200 OK" $ do + response <- get "http://example.com" :: IO (Response String) + responseStatus response `shouldBe` 200 + + it "should send a request to example.com and return 200 OK" $ do + response <- send (Request GET "http://example.com" [] ()) :: IO (Response String) + responseStatus response `shouldBe` 200 + + it "should post to postman-echo.com/post and return 200 OK" $ do + response <- post "https://postman-echo.com/post" ("Hello!" :: BS.ByteString) :: IO (Response String) + responseStatus response `shouldBe` 200 + + it "should put to postman-echo.com/put and return 200 OK" $ do + response <- put "https://postman-echo.com/put" ("Hello!" :: BS.ByteString) :: IO (Response String) + responseStatus response `shouldBe` 200 + + it "should patch to postman-echo.com/patch and return 200 OK" $ do + response <- patch "https://postman-echo.com/patch" ("Hello!" :: BS.ByteString) :: IO (Response String) + responseStatus response `shouldBe` 200 + + it "should use dot record syntax to create and access request/response" $ do + let req = Request { method = GET, url = "http://example.com", headers = [("User-Agent", "Haskell-Request")], body = () } + response <- send req :: IO (Response String) + response.status `shouldBe` 200 + response.headers `shouldSatisfy` (not . null) + + it "should access response body with different types" $ do + -- Test with ByteString body + let req1 = Request { method = GET, url = "http://example.com", headers = [], body = () } + response1 <- send req1 :: IO (Response BS.ByteString) + BS.length response1.body `shouldSatisfy` (> 0) + + -- Test with String body + let req2 = Request { method = GET, url = "http://example.com", headers = [], body = () } + response2 <- send req2 :: IO (Response String) + not (null response2.body) `shouldBe` True + + it "should correctly handle UTF-8 encoded response (Chinese characters)" $ do + let msg = "{\"message\":\"你好世界\"}" + let req = Request + { method = POST + , url = "https://postman-echo.com/post" + , headers = [("Content-Type", "application/json; charset=utf-8")] + , body = T.encodeUtf8 $ T.pack msg + } + response <- send req + responseStatus response `shouldBe` 200 + responseBody response `shouldSatisfy` isInfixOf "你好世界" + + it "should correctly handle UTF-8 encoded response (emoji)" $ do + let msg = "{\"message\":\"Hello 🌍\"}" + let req = Request + { method = POST + , url = "https://postman-echo.com/post" + , headers = [("Content-Type", "application/json; charset=utf-8")] + , body = T.encodeUtf8 $ T.pack msg + } + response <- send req + responseStatus response `shouldBe` 200 + responseBody response `shouldSatisfy` isInfixOf "🌍" + + it "should parse JSON response with aeson" $ do + response <- get "https://api.leancloud.cn/1.1/date" :: IO (Response Date) + responseStatus response `shouldBe` 200 + __type (responseBody response) `shouldBe` "Date" + iso (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 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 + responseBody response `shouldSatisfy` isInfixOf defaultUserAgent + + it "should not override user provided User-Agent" $ do + let customUserAgent = "custom-user-agent-for-test" + let req = Request GET "https://postman-echo.com/get" [("User-Agent", T.encodeUtf8 $ T.pack customUserAgent)] () + response <- send req :: IO (Response String) + responseStatus response `shouldBe` 200 + responseBody response `shouldSatisfy` isInfixOf customUserAgent + responseBody response `shouldSatisfy` not . isInfixOf defaultUserAgent + + it "should send with a user-provided manager" $ do + mgr <- newManager + response <- sendWith mgr (Request GET "http://example.com" [] ()) :: IO (Response String) + responseStatus response `shouldBe` 200 + + it "should stream response body as raw byte chunks" $ do + let req = Request GET "http://example.com" [] () + resp <- send req :: IO (Response (StreamBody BS.ByteString)) + resp.status `shouldBe` 200 + mChunk <- resp.body.readNext + resp.body.closeStream + mChunk `shouldSatisfy` (/= Nothing) + + it "should parse and stream SSE events" $ do + let req = Request GET "https://sse.dev/test" [] () + resp <- send req :: IO (Response (StreamBody SseEvent)) + resp.status `shouldBe` 200 + mEvent <- resp.body.readNext + resp.body.closeStream + case mEvent of + Nothing -> expectationFailure "Expected at least one SSE event from the stream" + Just _ -> return ()