ClientIntegrationSpec.hs

{-# language OverloadedStrings #-}
module HTTP.ClientIntegrationSpec (tests) where

import Data.Aeson (FromJSON(..), eitherDecode, withObject, (.:))
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Text as T

import Test.Tasty
import Test.Tasty.HUnit

import qualified Network.HTTP.Client as HC

import Network.Wai.Handler.Warp (Port)

import HTTP.Client (Header, knownMethods, robustSettings)
import HTTP.EchoServer (withEchoServer)

-- ---------------------------------------------------------------------------
-- EchoResponse — mirrors the JSON produced by HTTP.EchoServer
-- ---------------------------------------------------------------------------

data EchoResponse = EchoResponse
    { echoMethod :: T.Text
    , echoPath :: T.Text
    , echoQuery :: T.Text
    , echoHeaders :: Map T.Text T.Text
    , echoBody :: T.Text
    } deriving (Eq, Show)

instance FromJSON EchoResponse where
    parseJSON = withObject "EchoResponse" $ \o ->
        EchoResponse
            <$> o .: "method"
            <*> o .: "path"
            <*> o .: "query"
            <*> o .: "headers"
            <*> o .: "body"

-- ---------------------------------------------------------------------------
-- Helpers
-- ---------------------------------------------------------------------------

echoURL :: Port -> String -> String
echoURL port path = "http://localhost:" <> show port <> path

-- | Build and send an HTTP request using the restman 'robustSettings' manager,
-- then decode the echo server's JSON response.
sendRequest
    :: HC.Manager
    -> String        -- ^ Absolute URL
    -> String        -- ^ HTTP method string
    -> [Header]      -- ^ Extra request headers
    -> BL.ByteString -- ^ Request body (may be empty)
    -> IO EchoResponse
sendRequest mgr url method extraHdrs body = do
    req <- HC.parseRequest url
    let req' = req
            { HC.method         = BS8.pack method
            , HC.requestBody    = HC.RequestBodyLBS body
            , HC.requestHeaders = extraHdrs <> HC.requestHeaders req
            }
    resp <- HC.httpLbs req' mgr
    case eitherDecode (HC.responseBody resp) of
        Left err -> assertFailure ("Failed to decode echo response: " <> err)
        Right er -> pure er

-- ---------------------------------------------------------------------------
-- Tests
-- ---------------------------------------------------------------------------

tests :: TestTree
tests = testGroup "HTTP.Client (integration)"
    [ methodTests
    , headerTests
    , bodyTests
    ]

-- CONNECT requires proxy tunnelling semantics; HEAD strips the response body.
-- Both are excluded from the generic reflection test.
testableMethods :: [String]
testableMethods = filter (`notElem` ["CONNECT", "HEAD"]) knownMethods

methodTests :: TestTree
methodTests = testGroup "method reflection"
    [ testCase ("reflects " <> m) $ withEchoServer $ \port -> do
        mgr <- HC.newManager robustSettings
        er  <- sendRequest mgr (echoURL port "/") m [] ""
        echoMethod er @?= T.pack m
    | m <- testableMethods
    ]

headerTests :: TestTree
headerTests = testGroup "header reflection"
    [ testCase "single custom header is echoed" $ withEchoServer $ \port -> do
        mgr <- HC.newManager robustSettings
        er  <- sendRequest mgr (echoURL port "/") "GET"
                   [("X-Restman-Test", "hello")] ""
        Map.lookup "x-restman-test" (echoHeaders er) @?= Just "hello"

    , testCase "multiple custom headers are all echoed" $ withEchoServer $ \port -> do
        mgr <- HC.newManager robustSettings
        er  <- sendRequest mgr (echoURL port "/") "GET"
                   [("X-Foo", "foo-value"), ("X-Bar", "bar-value")] ""
        Map.lookup "x-foo" (echoHeaders er) @?= Just "foo-value"
        Map.lookup "x-bar" (echoHeaders er) @?= Just "bar-value"

    , testCase "header value is preserved verbatim" $ withEchoServer $ \port -> do
        mgr <- HC.newManager robustSettings
        er  <- sendRequest mgr (echoURL port "/") "GET"
                   [("X-Custom", "value with spaces")] ""
        Map.lookup "x-custom" (echoHeaders er) @?= Just "value with spaces"
    ]

bodyTests :: TestTree
bodyTests = testGroup "body and path reflection"
    [ testCase "POST body is echoed" $ withEchoServer $ \port -> do
        mgr <- HC.newManager robustSettings
        er  <- sendRequest mgr (echoURL port "/echo") "POST" [] "hello world"
        echoBody er @?= "hello world"

    , testCase "PUT body is echoed" $ withEchoServer $ \port -> do
        mgr <- HC.newManager robustSettings
        er  <- sendRequest mgr (echoURL port "/data") "PUT" [] "{\"key\":\"value\"}"
        echoBody er @?= "{\"key\":\"value\"}"

    , testCase "PATCH body is echoed" $ withEchoServer $ \port -> do
        mgr <- HC.newManager robustSettings
        er  <- sendRequest mgr (echoURL port "/patch") "PATCH" [] "patch-body"
        echoBody er @?= "patch-body"

    , testCase "path is reflected correctly" $ withEchoServer $ \port -> do
        mgr <- HC.newManager robustSettings
        er  <- sendRequest mgr (echoURL port "/some/path") "GET" [] ""
        echoPath er @?= "/some/path"

    , testCase "query string is reflected correctly" $ withEchoServer $ \port -> do
        mgr <- HC.newManager robustSettings
        er  <- sendRequest mgr (echoURL port "/search?q=restman&limit=10") "GET" [] ""
        echoQuery er @?= "?q=restman&limit=10"

    , testCase "empty body is reflected as empty text" $ withEchoServer $ \port -> do
        mgr <- HC.newManager robustSettings
        er  <- sendRequest mgr (echoURL port "/") "GET" [] ""
        echoBody er @?= ""
    ]