tests/testthat/test-Fireproof.R

In fireproof: Authentication and Authorization for 'fiery' Servers

test_that("Fireproof can be constructed", {
  fp <- Fireproof$new()

  expect_s3_class(fp, "Fireproof")
  expect_equal(fp$name, "fireproof")
  expect_equal(fp$require, "firesale")
})

test_that("Fireproof add_guard adds a Guard object", {
  fp <- Fireproof$new()

  guard <- guard_basic(
    validate = function(username, password) TRUE,
    name = "test_guard"
  )

  fp$add_guard(guard, "basic_auth")

  expect_equal(fp$guards, "basic_auth")
  expect_length(fp$guards, 1)
})

test_that("Fireproof add_guard adds multiple guards", {
  fp <- Fireproof$new()

  basic <- guard_basic(
    validate = function(username, password) TRUE,
    name = "basic"
  )
  key <- guard_key(
    key_name = "api-key",
    validate = "secret",
    name = "key"
  )

  fp$add_guard(basic, "basic_auth")
  fp$add_guard(key, "key_auth")

  expect_equal(fp$guards, c("basic_auth", "key_auth"))
  expect_length(fp$guards, 2)
})

test_that("Fireproof add_guard accepts function", {
  fp <- Fireproof$new()

  custom_guard <- function(request, response, keys) {
    TRUE
  }

  fp$add_guard(custom_guard, "custom")

  expect_equal(fp$guards, "custom")
})

test_that("Fireproof add_guard handles guard name", {
  fp <- Fireproof$new()

  guard <- guard_basic(
    validate = function(username, password) TRUE,
    name = "default_name"
  )

  fp$add_guard(guard)

  expect_equal(fp$guards, "default_name")

  fp$add_guard(guard, "new_name")
  expect_equal(guard$name, "new_name")

  custom_guard <- function(request, response, keys) TRUE

  expect_snapshot(
    fp$add_guard(custom_guard),
    error = TRUE
  )
})

test_that("Fireproof add_guard rejects invalid guard types", {
  fp <- Fireproof$new()

  expect_snapshot(
    fp$add_guard("not_a_guard", "invalid"),
    error = TRUE
  )

  expect_snapshot(
    fp$add_guard(123, "invalid"),
    error = TRUE
  )
})

test_that("Fireproof add_auth works", {
  fp <- Fireproof$new()

  guard <- guard_basic(
    validate = function(username, password) TRUE,
    name = "basic"
  )
  fp$add_guard(guard, "basic_auth")


  flow <- fp$add_auth("get", "/protected", basic_auth)
  expect_s3_class(flow, "fireproof_op")
  expect_null(attr(flow, "op"))  # scalar
})

test_that("Fireproof add_auth handles complex flows", {
  fp <- Fireproof$new()

  basic <- guard_basic(
    validate = function(username, password) TRUE,
    name = "basic"
  )
  key <- guard_key(
    key_name = "api-key",
    validate = "secret",
    name = "key"
  )
  bearer <- guard_bearer(
    validate = function(token) TRUE,
    name = "bearer"
  )

  fp$add_guard(basic, "basic_auth")
  fp$add_guard(key, "key_auth")
  fp$add_guard(bearer, "bearer_auth")

  flow <- fp$add_auth("get", "/protected", basic_auth || key_auth)

  expect_s3_class(flow, "fireproof_op")
  expect_equal(attr(flow, "op"), "||")
  expect_length(flow, 2)

  flow <- fp$add_auth("get", "/protected2", basic_auth && key_auth)

  expect_s3_class(flow, "fireproof_op")
  expect_equal(attr(flow, "op"), "&&")
  expect_length(flow, 2)

  flow <- fp$add_auth(
    "get",
    "/protected3",
    bearer_auth || (basic_auth && key_auth)
  )

  expect_s3_class(flow, "fireproof_op")
  expect_equal(attr(flow, "op"), "||")
})

test_that("Fireproof add_auth with NULL flow disables auth", {
  fp <- Fireproof$new()
  basic <- guard_basic(
    validate = function(username, password) TRUE
  )
  fp$add_guard(basic, "basic_auth")

  fp$add_auth("get", "/*", basic_auth)
  bad_req <- reqres::Request$new(fiery::fake_request("http://example.com/public"))

  expect_snapshot(
    fp$dispatch(bad_req, server = new.env(), arg_list = list(datastore = new.env())),
    error = TRUE
  )

  fp$add_auth("get", "/public", NULL)

  pass <- fp$dispatch(bad_req, server = new.env(), arg_list = list(datastore = new.env()))
  expect_true(pass)
})

test_that("Fireproof add_handler is defunct", {
  fp <- Fireproof$new()

  expect_snapshot(
    fp$add_handler("get", "/path", function() {}),
    error = TRUE
  )
})

test_that("Fireproof flow_to_openapi converts simple flow", {
  fp <- Fireproof$new()

  basic <- guard_basic(
    validate = function(username, password) TRUE,
    name = "basic"
  )
  fp$add_guard(basic, "basic_auth")

  flow <- fp$add_auth("get", "/protected", basic_auth)
  openapi <- fp$flow_to_openapi(flow, scope = c("read"))

  expect_type(openapi, "list")
  expect_length(openapi, 1)
  expect_true("basic_auth" %in% names(openapi[[1]]))
  expect_equal(openapi[[1]]$basic_auth, c("read"))
})

test_that("Fireproof flow_to_openapi converts OR flow", {
  fp <- Fireproof$new()

  basic <- guard_basic(
    validate = function(username, password) TRUE,
    name = "basic"
  )
  key <- guard_key(
    key_name = "api-key",
    validate = "secret",
    name = "key"
  )

  fp$add_guard(basic, "basic_auth")
  fp$add_guard(key, "key_auth")

  flow <- fp$add_auth("get", "/protected", basic_auth || key_auth)
  openapi <- fp$flow_to_openapi(flow, scope = character())

  expect_type(openapi, "list")
  expect_length(openapi, 2)
  expect_true("basic_auth" %in% names(openapi[[1]]))
  expect_true("key_auth" %in% names(openapi[[2]]))
})

test_that("Fireproof flow_to_openapi handles AND within OR", {
  fp <- Fireproof$new()

  basic <- guard_basic(
    validate = function(username, password) TRUE,
    name = "basic"
  )
  key <- guard_key(
    key_name = "api-key",
    validate = "secret",
    name = "key"
  )
  bearer <- guard_bearer(
    validate = function(token) TRUE,
    name = "bearer"
  )

  fp$add_guard(basic, "basic_auth")
  fp$add_guard(key, "key_auth")
  fp$add_guard(bearer, "bearer_auth")

  flow <- fp$add_auth(
    "get",
    "/protected",
    bearer_auth || (basic_auth && key_auth)
  )
  openapi <- fp$flow_to_openapi(flow, scope = character())

  expect_type(openapi, "list")
  expect_length(openapi, 2)
  # First alternative: bearer_auth
  expect_true("bearer_auth" %in% names(openapi[[1]]))
  # Second alternative: basic_auth AND key_auth
  expect_true("basic_auth" %in% names(openapi[[2]]))
  expect_true("key_auth" %in% names(openapi[[2]]))
})

test_that("Fireproof flow_to_openapi warns on deeply nested flow", {
  fp <- Fireproof$new()

  auth1 <- guard_basic(validate = function(u, p) TRUE, name = "a1")
  auth2 <- guard_key(key_name = "k", validate = "s", name = "a2")
  auth3 <- guard_bearer(validate = function(t) TRUE, name = "a3")

  fp$add_guard(auth1, "auth1")
  fp$add_guard(auth2, "auth2")
  fp$add_guard(auth3, "auth3")

  # Create depth > 2 flow (invalid for OpenAPI)
  # This will be: and(or(and(...))) which is depth 3
  inner <- and("auth1", "auth2")
  middle <- or(inner, "auth3")
  outer <- and(middle, "auth1")

  expect_snapshot(
    result <- fp$flow_to_openapi(outer, scope = character())
  )
  expect_null(result)
})

test_that("Fireproof print method shows summary", {
  fp <- Fireproof$new()

  basic <- guard_basic(
    validate = function(username, password) TRUE,
    name = "basic"
  )
  fp$add_guard(basic, "basic_auth")
  fp$add_auth("get", "/protected", basic_auth)

  output <- capture.output(print(fp))

  expect_true(any(grepl("fireproof plugin", output)))
  expect_true(any(grepl("1.*guard", output)))
  expect_true(any(grepl("1.*handler", output)))
})

test_that("Fireproof print method handles multiple guards and handlers", {
  fp <- Fireproof$new()

  basic <- guard_basic(
    validate = function(username, password) TRUE,
    name = "basic"
  )
  key <- guard_key(
    key_name = "api-key",
    validate = "secret",
    name = "key"
  )

  fp$add_guard(basic, "basic_auth")
  fp$add_guard(key, "key_auth")
  fp$add_auth("get", "/path1", basic_auth)
  fp$add_auth("post", "/path2", key_auth)

  output <- capture.output(print(fp))

  expect_true(any(grepl("2.*guard", output)))
  expect_true(any(grepl("2.*handler", output)))
})

test_that("parse_auth_flow parses single symbol", {
  flow <- parse_auth_flow(basic_auth)

  expect_s3_class(flow, "fireproof_op")
  expect_null(attr(flow, "op"))
  expect_equal(flow[[1]], "basic_auth")
})

test_that("parse_auth_flow parses OR expression", {
  flow <- parse_auth_flow(auth1 || auth2)

  expect_s3_class(flow, "fireproof_op")
  expect_equal(attr(flow, "op"), "||")
  expect_equal(flow[[1]], "auth1")
  expect_equal(flow[[2]], "auth2")
})

test_that("parse_auth_flow parses AND expression", {
  flow <- parse_auth_flow(auth1 && auth2)

  expect_s3_class(flow, "fireproof_op")
  expect_equal(attr(flow, "op"), "&&")
  expect_equal(flow[[1]], "auth1")
  expect_equal(flow[[2]], "auth2")
})

test_that("parse_auth_flow parses nested expression", {
  flow <- parse_auth_flow((auth1 && auth2) || auth3)

  expect_s3_class(flow, "fireproof_op")
  expect_equal(attr(flow, "op"), "||")
  expect_length(flow, 2)
  expect_s3_class(flow[[1]], "fireproof_op")
  expect_equal(attr(flow[[1]], "op"), "&&")
})

test_that("parse_auth_flow handles parentheses", {
  flow <- parse_auth_flow((auth1))

  expect_s3_class(flow, "fireproof_op")
  expect_equal(flow[[1]], "auth1")
})

test_that("parse_auth_flow returns NULL for NULL input", {
  flow <- parse_auth_flow(NULL)

  expect_null(flow)
})

test_that("parse_auth_flow rejects invalid operators", {
  expect_snapshot(
    parse_auth_flow(auth1 + auth2),
    error = TRUE
  )

  expect_snapshot(
    parse_auth_flow(auth1 & auth2),
    error = TRUE
  )
})

test_that("parse_auth_flow collapses same operators", {
  # auth1 || auth2 || auth3 should collapse to single OR with 3 elements
  flow <- parse_auth_flow(auth1 || auth2 || auth3)

  expect_s3_class(flow, "fireproof_op")
  expect_equal(attr(flow, "op"), "||")
  expect_length(flow, 3)
})

test_that("Fireproof on_attach creates RouteStack if missing", {
  skip_if_not_installed("fiery")

  fp <- Fireproof$new()
  app <- fiery::Fire$new()

  # No RouteStack yet
  expect_null(app$plugins$request_routr)

  fp$on_attach(app)

  # RouteStack should now exist
  expect_s3_class(app$plugins$request_routr, "RouteStack")
})

test_that("Fireproof on_attach adds itself to RouteStack", {
  skip_if_not_installed("fiery")
  skip_if_not_installed("routr")

  fp <- Fireproof$new()
  app <- fiery::Fire$new()

  fp$on_attach(app)

  # Check that fireproof is in the route stack
  routes <- app$plugins$request_routr$routes
  expect_true("fireproof_auth" %in% routes)
})

test_that("Fireproof on_attach uses existing RouteStack", {
  skip_if_not_installed("fiery")
  skip_if_not_installed("routr")

  fp <- Fireproof$new()
  app <- fiery::Fire$new()

  # Pre-create RouteStack
  rs <- routr::RouteStack$new()
  rs$attach_to <- "request"
  app$attach(rs)

  initial_count <- length(app$plugins$request_routr$routes)

  fp$on_attach(app)

  # Should have added one more route
  expect_equal(
    length(app$plugins$request_routr$routes),
    initial_count + 1
  )
})

test_that("Fireproof handles quoted guard names", {
  flow <- parse_auth_flow("basic_auth")

  expect_s3_class(flow, "fireproof_op")
  expect_equal(flow[[1]], "basic_auth")
})

test_that("Fireproof handles single-quoted guard names", {
  flow <- parse_auth_flow('basic_auth')

  expect_s3_class(flow, "fireproof_op")
  expect_equal(flow[[1]], "basic_auth")
})

test_that("Fireproof add_guard calls register_handler on Guard", {
  fp <- Fireproof$new()

  # Create a guard that tracks if register_handler was called
  guard <- guard_basic(
    validate = function(username, password) TRUE,
    name = "basic"
  )

  # Guard's register_handler should be called
  fp$add_guard(guard, "basic_auth")

  # No direct way to test this without mocking, but we can verify no error
  expect_true(TRUE)
})

test_that("Fireproof format method for flow works", {
  flow <- parse_auth_flow(auth1 || auth2)

  formatted <- format(flow)

  expect_type(formatted, "character")
  expect_true(grepl("\\|\\|", formatted))
})

test_that("Fireproof handles multiple methods for same path", {
  fp <- Fireproof$new()

  guard <- guard_basic(
    validate = function(username, password) TRUE,
    name = "basic"
  )
  fp$add_guard(guard, "basic_auth")

  expect_no_error({
    fp$add_auth("get", "/path", basic_auth)
    fp$add_auth("post", "/path", basic_auth)
    fp$add_auth("delete", "/path", basic_auth)
  })
})

test_that("Fireproof handles wildcard paths", {
  fp <- Fireproof$new()

  guard <- guard_basic(
    validate = function(username, password) TRUE,
    name = "basic"
  )
  fp$add_guard(guard, "basic_auth")

  expect_no_error(
    fp$add_auth("all", "/*", basic_auth)
  )
})