tests/testthat/test-request_matcher.R

In vcr: Record 'HTTP' Calls to Disk

test_that("multiple matchers requires all to match", {
  expect_true(request_matches(
    list(method = "GET", uri = "http://a.com"),
    list(method = "GET", uri = "http://a.com"),
    c("method", "uri")
  ))
  expect_false(request_matches(
    list(method = "GET", uri = "http://a.com"),
    list(method = "GET", uri = "http://b.com"),
    c("method", "uri")
  ))
})

test_that("request_matches has useful logging", {
  local_vcr_configure_log(file = stdout())

  req1 <- list(uri = "http://example.com", method = "GET")
  req2 <- list(uri = "http://example.com/foo", method = "GET")
  req3 <- list(uri = "http://example.com", method = "POST")
  req4 <- list(uri = "http://example.com/foo", method = "POST")

  expect_snapshot({
    . <- request_matches(req1, req1)
    . <- request_matches(req1, req2)
    . <- request_matches(req1, req3)
    . <- request_matches(req1, req4)
  })
})

test_that("informative feedback for components that are absent", {
  local_vcr_configure_log(file = stdout())

  req1 <- list(uri = "http://example.com", method = "GET")
  req2 <- list(uri = "http://example.com?q=1", method = "GET")

  expect_snapshot({
    . <- request_matches(req1, req2)
  })
})

test_that("query parameters are normalised", {
  expect_true(request_matches(
    list(uri = "http://a.com/foo?foo=%C2%B5"),
    list(uri = "http://a.com/bar?foo=\u00b5"),
    "query"
  ))
})

test_that("make_comparison extracts expected componets", {
  req <- list(
    method = "GET",
    uri = "http://a.com/foo?bar=baz",
    body = "body",
    headers = list(name = "value")
  )

  # Straightforward extraction
  expect_equal(make_comparison("body", req), req["body"])
  expect_equal(make_comparison("headers", req), req["headers"])
  expect_equal(make_comparison("method", req), req["method"])

  # URI manipulation
  expect_equal(make_comparison("host", req), list(host = "a.com"))
  expect_equal(make_comparison("path", req), list(path = "/foo"))
  expect_equal(make_comparison("query", req), list(query = list(bar = "baz")))
})

test_that("default uri extraction ignores port", {
  req <- list(method = "GET", uri = "http://x.com:123")

  expect_equal(make_comparison("uri", req)$uri$port, NULL)
  expect_equal(make_comparison("uri_with_port", req)$uri$port, "123")
})

test_that("query params are normalized", {
  expect_equal(
    make_comparison("query", list(uri = "http://a.com/foo?foo=%C2%B5")),
    list(query = list(foo = "\u00b5"))
  )
})

test_that("query params are filtered", {
  local_vcr_configure(filter_query_parameters = "foo")

  expect_equal(
    make_comparison("query", list(uri = "http://a.com/"))$query,
    set_names(list())
  )

  expect_equal(
    make_comparison("query", list(uri = "http://a.com/?foo=x"))$query,
    set_names(list())
  )
})

test_that("json_body ignores representation", {
  req1 <- list(body = '{"foo": "bar"}')
  req2 <- list(body = '{"foo":     "bar"}')

  expect_equal(
    make_comparison("body_json", req1),
    list(body = list(foo = "bar"))
  )

  expect_true(request_matches(req1, req2, "body_json"))
})

# End to end tests -------------------------------------------------------------

test_that("can match empty bodies", {
  local_vcr_configure(
    dir = withr::local_tempdir(),
    match_requests_on = c("method", "uri", "body")
  )
  cli <- crul::HttpClient$new(url = hb())

  use_cassette("test", res1 <- cli$post("post"))
  expect_null(res1$request$body)
  use_cassette("test", res1_replay <- cli$post("post"))
  expect_null(res1_replay$request$body)

  # the request body in the cassette is empty
  expect_false(has_name(vcr_last_request(), "body"))
})

test_that("can match json bodies", {
  local_vcr_configure(
    dir = withr::local_tempdir(),
    match_requests_on = c("method", "uri", "body_json")
  )

  req <- httr2::request(hb("/post"))
  req <- httr2::req_body_json(req, list(foo = "bar"))
  # record
  use_cassette("test", res1 <- httr2::req_perform(req))
  # replay
  use_cassette("test", res1 <- httr2::req_perform(req))

  expect_equal(vcr_last_request()$body, list(string = '{"foo":"bar"}'))
})


test_that("default matcher includes body_json", {
  local_vcr_configure(dir = withr::local_tempdir())
  local_vcr_configure_log(file = stdout())

  req <- httr2::request(hb("/post"))
  req1 <- httr2::req_body_json(req, list(foo = "bar"))
  req2 <- httr2::req_body_json(req, list(foo = "baz"))

  use_cassette("test", httr2::req_perform(req1))
  expect_snapshot(
    use_cassette("test", httr2::req_perform(req2)),
    error = TRUE,
    transform = \(x) gsub(hb(), "{httpbin}", x, fixed = TRUE),
  )
})

test_that("default matcher includes body", {
  local_vcr_configure(dir = withr::local_tempdir())
  local_vcr_configure_log(file = stdout())

  req <- httr2::request(hb("/post"))
  req1 <- httr2::req_body_form(req, foo = "bar")
  req2 <- httr2::req_body_form(req, foo = "baz")

  use_cassette("test", httr2::req_perform(req1))
  expect_snapshot(
    use_cassette("test", httr2::req_perform(req2)),
    error = TRUE,
    transform = \(x) gsub(hb(), "{httpbin}", x, fixed = TRUE),
  )
})


test_that('request matching is not sensitive to escaping special characters', {
  local_vcr_configure(dir = withr::local_tempdir())
  url <- hb("/get?update=2022-01-01T00:00:00&p2=ok")

  # curl does not escape
  aa <- use_cassette('test', res <- crul::HttpClient$new(url)$get())
  expect_true(res$status_code == 200)

  # httr does escape
  bb <- use_cassette('test', res <- httr::GET(url))
  expect_true(res$status_code == 200)
})