request-0.5.0.0: test/Spec.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase  #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

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
  } deriving (Show, Generic)

instance FromJSON UUID

data Greeting = Greeting
  { message :: String
  } deriving (Show, Generic)

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)
             ]

-- | 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

    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://httpbin.org/uuid" :: IO (Response UUID)
      responseStatus response `shouldBe` 200
      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 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
      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
      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 build a Basic Authorization header value" $ do
      basicAuth "alice" "s3cret" `shouldBe` "Basic YWxpY2U6czNjcmV0"

    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
      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://stream.wikimedia.org/v2/stream/recentchange" [] ()
      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 ()