tests/testthat/test-tool-github.R

In btw: A Toolkit for Connecting R and Large Language Models

# Helper to scrub dynamic GitHub content for snapshots
scrub_github_content <- function(x) {
  # Scrub timestamps
  x <- gsub("\\d{4}-\\d{2}-\\d{2}T\\d{2}:\\d{2}:\\d{2}Z", "TIMESTAMP", x)
  # Scrub GitHub URLs with actual domains
  x <- gsub("https://github\\.com/[^\\s]+", "GITHUB_URL", x)
  # Scrub GitHub API URLs
  x <- gsub("https://api\\.github\\.com/[^\\s]+", "API_URL", x)
  x
}

# Tests for btw_gh() endpoint validation ---------------------------------------

test_that("btw_github_parse_endpoint() parses endpoints correctly", {
  # With verb
  expect_equal(
    btw_github_parse_endpoint("GET /repos/owner/repo"),
    list(verb = "GET", path = "/repos/owner/repo")
  )

  expect_equal(
    btw_github_parse_endpoint("POST /repos/owner/repo/issues"),
    list(verb = "POST", path = "/repos/owner/repo/issues")
  )

  # Without verb (defaults to GET)
  expect_equal(
    btw_github_parse_endpoint("/repos/owner/repo"),
    list(verb = "GET", path = "/repos/owner/repo")
  )

  # Without leading slash
  expect_equal(
    btw_github_parse_endpoint("repos/owner/repo"),
    list(verb = "GET", path = "/repos/owner/repo")
  )

  # Case insensitive verb
  expect_equal(
    btw_github_parse_endpoint("get /repos/owner/repo"),
    list(verb = "GET", path = "/repos/owner/repo")
  )

  # With template variables
  expect_equal(
    btw_github_parse_endpoint(
      "GET /repos/{owner}/{repo}/issues/{issue_number}"
    ),
    list(verb = "GET", path = "/repos/{owner}/{repo}/issues/{issue_number}")
  )
})

test_that("btw_github_match_pattern() matches patterns correctly", {
  # Exact matches
  expect_true(btw_github_match_pattern(
    "GET /repos/owner/repo",
    "GET /repos/*/*"
  ))

  # Template variables
  expect_true(btw_github_match_pattern(
    "GET /repos/{owner}/{repo}/issues/{issue_number}",
    "GET /repos/*/*/issues/*"
  ))

  # Literal values
  expect_true(btw_github_match_pattern(
    "GET /repos/posit-dev/btw/issues/123",
    "GET /repos/*/*/issues/*"
  ))

  # Mixed template and literal
  expect_true(btw_github_match_pattern(
    "GET /repos/posit-dev/btw/issues/{issue_number}",
    "GET /repos/*/*/issues/*"
  ))

  # Double star matches zero segments
  expect_true(btw_github_match_pattern(
    "GET /repos/owner/repo/commits",
    "GET /repos/*/*/commits/**"
  ))

  # Double star matches one segment
  expect_true(btw_github_match_pattern(
    "GET /repos/owner/repo/commits/abc123",
    "GET /repos/*/*/commits/**"
  ))

  # Double star matches multiple segments
  expect_true(btw_github_match_pattern(
    "GET /repos/owner/repo/commits/abc123/status",
    "GET /repos/*/*/commits/**"
  ))

  # Verb mismatch
  expect_false(btw_github_match_pattern(
    "POST /repos/owner/repo",
    "GET /repos/*/*"
  ))

  # Path segment count mismatch (without **)
  expect_false(btw_github_match_pattern(
    "GET /repos/owner/repo/issues",
    "GET /repos/*/*"
  ))

  # Path segment mismatch
  expect_false(btw_github_match_pattern(
    "GET /repos/owner/repo/pulls",
    "GET /repos/*/*/issues"
  ))

  # Double star doesn't match if prefix doesn't match
  expect_false(btw_github_match_pattern(
    "GET /repos/owner/repo/issues/123",
    "GET /repos/*/*/commits/**"
  ))
})

test_that("btw_gh() allows safe read operations on issues and PRs", {
  local_mocked_bindings(
    gh = function(...) list(status = "ok"),
    .package = "gh"
  )

  # Reading issues and PRs should be safe
  expect_no_error(btw_gh("GET /repos/owner/repo/issues/123"))
  expect_no_error(btw_gh("/repos/owner/repo/issues/123"))
  expect_no_error(btw_gh("GET /repos/owner/repo/issues/123/comments"))
  expect_no_error(btw_gh("GET /repos/owner/repo/pulls/456"))
  expect_no_error(btw_gh("GET /repos/owner/repo/pulls/456/files"))
})

test_that("btw_gh() allows creating issues, PRs, and comments", {
  local_mocked_bindings(
    gh = function(...) list(status = "ok"),
    .package = "gh"
  )

  # Creating issues and PRs should be allowed
  expect_no_error(btw_gh("POST /repos/owner/repo/issues"))
  expect_no_error(btw_gh("POST /repos/owner/repo/pulls"))
  expect_no_error(btw_gh("POST /repos/owner/repo/issues/123/comments"))
})

test_that("btw_gh() blocks dangerous operations", {
  local_mocked_bindings(
    gh = function(...) stop("Should not reach API"),
    .package = "gh"
  )

  # These operations should always be blocked as too dangerous
  expect_error(
    btw_gh("PUT /repos/owner/repo/pulls/123/merge"),
    "blocked"
  )

  expect_error(
    btw_gh("DELETE /repos/owner/repo"),
    "blocked"
  )

  expect_error(
    btw_gh("POST /repos/owner/repo/hooks"),
    "blocked"
  )

  expect_error(
    btw_gh("PUT /repos/owner/repo/actions/secrets/MY_SECRET"),
    "blocked"
  )
})

test_that("btw_gh() uses allowlist - unknown endpoints rejected by default", {
  local_mocked_bindings(
    gh = function(...) stop("Should not reach API"),
    .package = "gh"
  )

  # Endpoints not explicitly allowed should be rejected
  # Using clearly fictional/unlikely endpoints to avoid coupling to specific rules
  expect_error(
    btw_gh("GET /repos/owner/repo/xyz-nonexistent-endpoint"),
    "not allowed"
  )

  expect_error(
    btw_gh("POST /repos/owner/repo/xyz-made-up-action"),
    "not allowed"
  )
})

test_that("btw_gh() respects user allow rules", {
  local_mocked_bindings(
    gh = function(...) list(status = "ok"),
    .package = "gh"
  )

  # Use a fictional endpoint that definitely isn't in default rules
  fictional_endpoint <- "GET /repos/owner/repo/xyz-custom-endpoint"

  # Without user allow rule, should fail
  expect_error(
    btw_gh(fictional_endpoint),
    "not allowed"
  )

  # With user allow rule, should pass
  withr::local_options(btw.github.allow = fictional_endpoint)
  expect_no_error(btw_gh(fictional_endpoint))
})

test_that("btw_gh() respects user block rules", {
  local_mocked_bindings(
    gh = function(...) list(status = "ok"),
    .package = "gh"
  )

  # Use a fictional endpoint to test user blocking
  fictional_endpoint <- "GET /repos/owner/repo/xyz-test-endpoint"

  # First allow it via user rules
  withr::local_options(btw.github.allow = fictional_endpoint)
  expect_no_error(btw_gh(fictional_endpoint))

  # Now block it - user block should take precedence over user allow
  withr::local_options(
    btw.github.allow = fictional_endpoint,
    btw.github.block = fictional_endpoint
  )
  expect_error(
    btw_gh(fictional_endpoint),
    "blocked"
  )
})

test_that("btw_gh() user block rules take precedence over user allow rules", {
  local_mocked_bindings(
    gh = function(...) stop("Should not reach API"),
    .package = "gh"
  )

  fictional_endpoint <- "GET /repos/owner/repo/xyz-conflict-test"

  # Add both allow and block rules for the same endpoint
  withr::local_options(
    btw.github.allow = fictional_endpoint,
    btw.github.block = fictional_endpoint
  )

  # User block should take precedence over user allow
  expect_error(
    btw_gh(fictional_endpoint),
    "blocked"
  )
})

test_that("btw_gh() user allow rules can override built-in block rules", {
  local_mocked_bindings(
    gh = function(...) list(status = "ok"),
    .package = "gh"
  )

  # Merge is blocked by default
  merge_endpoint <- "PUT /repos/owner/repo/pulls/123/merge"

  # Should be blocked by default
  expect_error(
    btw_gh(merge_endpoint),
    "blocked"
  )

  # User allow should override built-in block
  withr::local_options(btw.github.allow = merge_endpoint)
  expect_no_error(btw_gh(merge_endpoint))
})

test_that("btw_gh() user block rules can override built-in allow rules", {
  local_mocked_bindings(
    gh = function(...) stop("Should not reach API"),
    .package = "gh"
  )

  # Reading issues is allowed by default
  issue_endpoint <- "GET /repos/owner/repo/issues/123"

  # Should be allowed by default
  local_mocked_bindings(
    gh = function(...) list(status = "ok"),
    .package = "gh"
  )
  expect_no_error(btw_gh(issue_endpoint))

  # User block should override built-in allow
  local_mocked_bindings(
    gh = function(...) stop("Should not reach API"),
    .package = "gh"
  )
  withr::local_options(btw.github.block = issue_endpoint)
  expect_error(
    btw_gh(issue_endpoint),
    "blocked"
  )
})

test_that("btw_gh() passes arguments through to gh::gh()", {
  local_mocked_bindings(
    gh = function(endpoint, ..., owner, repo) {
      list(
        endpoint = endpoint,
        owner = owner,
        repo = repo,
        dots = list(...)
      )
    },
    .package = "gh"
  )

  result <- btw_gh(
    "/repos/{owner}/{repo}/issues",
    owner = "posit-dev",
    repo = "btw",
    state = "open"
  )

  expect_equal(result$endpoint, "/repos/{owner}/{repo}/issues")
  expect_equal(result$owner, "posit-dev")
  expect_equal(result$repo, "btw")
  expect_equal(result$dots$state, "open")
})

# Tests for btw_tool_github() --------------------------------------------------

test_that("btw_tool_github() can get an issue", {
  skip_if_not_installed("gh")

  local_posit_dev_btw_repo()
  local_mocked_gh(mock_btw_issue_37)

  result <- btw_tool_github_impl(
    'gh("/repos/{owner}/{repo}/issues/37", owner = owner, repo = repo)'
  )

  expect_s7_class(result, BtwToolResult)
  expect_type(result@value, "list")

  expect_equal(result@value$number, 37)
  expect_equal(
    result@value$html_url,
    "https://github.com/posit-dev/btw/issues/37"
  )
})

test_that("btw_tool_github() can list issues", {
  skip_if_not_installed("gh")

  local_posit_dev_btw_repo()
  local_mocked_gh(mock_btw_issues_open)

  result <- btw_tool_github_impl(
    'gh("/repos/{owner}/{repo}/issues", state = "open", owner = owner, repo = repo)'
  )

  expect_s7_class(result, BtwToolResult)
  expect_type(result@value, "list")
})

test_that("btw_tool_github() can create an issue", {
  skip_if_not_installed("gh")

  local_posit_dev_btw_repo()
  local_mocked_gh()

  result <- btw_tool_github_impl(
    '
gh("POST /repos/{owner}/{repo}/issues",
  title = "Test issue",
  body = "Test body",
  owner = owner,
  repo = repo
)
  '
  )

  expect_s7_class(result, BtwToolResult)
  expect_type(result@value, "list")
  expect_equal(result@value$endpoint, "POST /repos/{owner}/{repo}/issues")
  expect_equal(result@value$payload$title, "Test issue")
  expect_equal(result@value$payload$body, "Test body")
  expect_equal(result@value$payload$owner, "posit-dev")
  expect_equal(result@value$payload$repo, "btw")
})

test_that("btw_tool_github() can get a pull request", {
  skip_if_not_installed("gh")

  local_posit_dev_btw_repo()
  local_mocked_gh()

  result <- btw_tool_github_impl(
    'gh("/repos/{owner}/{repo}/pulls/456", owner = owner, repo = repo)'
  )

  expect_s7_class(result, BtwToolResult)
  expect_type(result@value, "list")
  expect_equal(result@value$endpoint, "/repos/{owner}/{repo}/pulls/456")
  expect_equal(result@value$payload$owner, "posit-dev")
  expect_equal(result@value$payload$repo, "btw")
})

test_that("btw_tool_github() can get pull request files", {
  skip_if_not_installed("gh")

  local_posit_dev_btw_repo()
  local_mocked_gh()

  result <- btw_tool_github_impl(
    'gh("/repos/{owner}/{repo}/pulls/456/files", owner = owner, repo = repo)'
  )

  expect_s7_class(result, BtwToolResult)
  expect_type(result@value, "list")
  expect_equal(result@value$endpoint, "/repos/{owner}/{repo}/pulls/456/files")
  expect_equal(result@value$payload$owner, "posit-dev")
  expect_equal(result@value$payload$repo, "btw")
})

test_that("btw_tool_github() can call gh_whoami", {
  skip_if_not_installed("gh")

  local_posit_dev_btw_repo()
  local_mocked_bindings(btw_gh_fields = function() NULL)
  local_mocked_bindings(
    gh_whoami = function() {
      structure(
        list(
          name = "Garrick Aden-Buie",
          login = "gadenbuie",
          html_url = "https://github.com/gadenbuie",
          scopes = "admin:org, gist, notifications, project, read:discussion, repo, user, workflow",
          token = "ghp_TOKEN_VALUE"
        ),
        class = c("gh_response", "list")
      )
    },
    .package = "gh"
  )

  result <- btw_tool_github_impl('gh_whoami()')

  expect_s7_class(result, BtwToolResult)
  expect_type(result@value, "list")
  expect_equal(result@value$login, "gadenbuie")
})

test_that("btw_tool_github() throws if using owner or repo that can't be found", {
  skip_if_not_installed("gh")

  local_mocked_bindings(
    gh_tree_remote = function() abort("not in a repo"),
    .package = "gh"
  )
  local_mocked_gh()

  expect_error(
    btw_tool_github_impl(
      'gh("/repos/{owner}/{repo}/issues/37", owner = owner, repo = repo)'
    ),
    "Could not detect GitHub repository"
  )

  expect_error(
    btw_tool_github_impl(
      'gh("/repos/{owner}/btw/issues/37", owner = owner)'
    ),
    "Could not detect GitHub repository"
  )

  expect_error(
    btw_tool_github_impl(
      'gh("/repos/posit-dev/{repo}/issues/37", repo = repo)'
    ),
    "Could not detect GitHub repository"
  )

  expect_equal(
    btw_tool_github_impl(
      'gh("/repos/posit-dev/btw/issues/37")'
    )@value$endpoint,
    "/repos/posit-dev/btw/issues/37"
  )
})

# Tool registration tests ------------------------------------------------------

test_that("github tool registers correctly", {
  skip_if_not_installed("gh")

  local_mocked_bindings(
    btw_can_register_gh_tool = function() TRUE
  )

  tools <- btw_tools("github")

  expect_true(length(tools) > 0)

  tool_names <- vapply(tools, function(t) t@name, character(1))

  expect_in("btw_tool_github", tool_names)
})

test_that("github tool requires gh package for registration", {
  local_mocked_bindings(
    btw_can_register_gh_tool = function() FALSE
  )

  tools <- btw_tools("github")

  # Should return empty list when gh is not installed or not authenticated
  expect_equal(length(tools), 0)
})

test_that("github tool has correct annotations", {
  skip_if_not_installed("gh")

  local_mocked_bindings(
    btw_can_register_gh_tool = function() TRUE
  )

  tools <- btw_tools("github")

  tool <- tools[[which(vapply(
    tools,
    function(t) t@name == "btw_tool_github",
    logical(1)
  ))]]

  expect_false(tool@annotations$read_only_hint)
  expect_true(tool@annotations$open_world_hint)
})