test-urlLog.R
In reproducible: Enhance Reproducibility of R Code

test_that("urlLog: destinationPath is normalized to an absolute path", {
  testInit()
  withr::local_options(reproducible.urlLog = TRUE)
  clearUrlLog()
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/a.tif",
                               destinationPath = ".")
  rec <- prepInputsLog()[[1]]
  expect_true(nzchar(rec$destinationPath))
  expect_false(identical(rec$destinationPath, "."))   # was expanded
  expect_true(startsWith(rec$destinationPath, "/") ||
              grepl("^[A-Za-z]:/", rec$destinationPath))  # absolute
})

test_that("urlLog: core record carries targetFile/archive/alsoExtract", {
  testInit()
  withr::local_options(reproducible.urlLog = TRUE)
  clearUrlLog()
  reproducible:::.logUrlAccess(
    "prepInputs", "https://example.com/a.zip",
    targetFile = "raster.tif",
    archive    = "raster.zip",
    alsoExtract = c("aux1", "aux2"),
    destinationPath = "/tmp"
  )
  rec <- prepInputsLog()[[1]]
  expect_equal(rec$targetFile, "raster.tif")
  expect_equal(rec$archive,    "raster.zip")
  expect_equal(rec$alsoExtract, "aux1; aux2")   # vector collapsed
  # The record stores the normPath()-resolved path (see .absPathOrNA), so the
  # expectation must normalize too: "/tmp" -> "/private/tmp" on macOS,
  # "C:/tmp" on Windows. Comparing to the literal "/tmp" only passes on Linux.
  expect_equal(rec$destinationPath, normPath("/tmp"))
})

test_that("urlLog: env sink merges sink$extra into each record (SpaDES module/event)", {
  testInit()
  e <- new.env(parent = emptyenv())
  e$extra <- list(module = "ageModule", event = "init")
  withr::local_options(reproducible.urlLog = e)
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/a.tif")

  rec <- e$records[[1]]
  expect_equal(rec$module, "ageModule")
  expect_equal(rec$event,  "init")

  ## Dynamic update: next event sets new module/event, picked up immediately.
  e$extra <- list(module = "vegModule", event = "step")
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/b.tif")
  rec2 <- e$records[[2]]
  expect_equal(rec2$module, "vegModule")
  expect_equal(rec2$event,  "step")

  ## Core columns win on key collisions: caller's `fn` doesn't override.
  e$extra <- list(fn = "hijacked", custom = "ok")
  reproducible:::.logUrlAccess("preProcess", "https://example.com/c.tif")
  rec3 <- e$records[[3]]
  expect_equal(rec3$fn,    "preProcess")  # core wins
  expect_equal(rec3$custom, "ok")
})

test_that("urlLog: one-time 'how to view' hint fires once per session", {
  testInit()
  withr::local_options(reproducible.urlLog = TRUE, reproducible.verbose = 1)
  clearUrlLog()
  ## reset the session-level announce flag so this test controls it
  assign("announced", FALSE, envir = reproducible:::.urlLogEnv)

  msg1 <- capture_messages(
    reproducible:::.logUrlAccess("prepInputs", "https://example.com/a.tif"))
  expect_true(any(grepl("prepInputsLog\\(\\)|showCache", msg1)))

  ## second access: no repeat hint
  msg2 <- capture_messages(
    reproducible:::.logUrlAccess("prepInputs", "https://example.com/b.tif"))
  expect_false(any(grepl("prepInputsLog\\(\\)|showCache", msg2)))
})

test_that("urlLog: FALSE is the kill switch", {
  testInit()
  withr::local_options(reproducible.urlLog = FALSE)
  clearUrlLog()
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/x.tif")
  expect_length(prepInputsLog(), 0L)
})

test_that("urlLog: default (NULL) captures bare prepInputs into in-memory log", {
  testInit()
  withr::local_options(reproducible.urlLog = NULL)
  clearUrlLog()
  ## bare prepInputs (no Cache, no explicit sink) still recorded by default
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/x.tif")
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/x.tif")  # dedup
  reproducible:::.logUrlAccess("preProcess", "https://example.com/y.tif")
  log <- prepInputsLog()
  expect_length(log, 2L)
  expect_setequal(vapply(log, function(r) r$url, character(1)),
                  c("https://example.com/x.tif", "https://example.com/y.tif"))
})

test_that("urlLog: TRUE sink + idempotency + clear", {
  testInit()
  withr::local_options(reproducible.urlLog = TRUE)
  clearUrlLog()

  reproducible:::.logUrlAccess("prepInputs", "https://example.com/a.tif",
                               destinationPath = "/tmp", cacheId = "abc")
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/a.tif",
                               destinationPath = "/tmp", cacheId = "abc")
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/b.tif",
                               destinationPath = "/tmp", cacheId = "abc")

  log <- prepInputsLog()
  expect_length(log, 2L)
  expect_equal(log[[1]]$url, "https://example.com/a.tif")
  expect_equal(log[[2]]$url, "https://example.com/b.tif")

  clearUrlLog()
  expect_length(prepInputsLog(), 0L)
})

test_that("urlLog: environment sink populates env$records and env$seen", {
  testInit()
  e <- new.env(parent = emptyenv())
  withr::local_options(reproducible.urlLog = e)

  ## Same (fn, url, cacheId) collapses to one record regardless of miss/hit.
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/a.tif",
                               cacheId = "abc")
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/a.tif",
                               cacheId = "abc")
  expect_length(e$records, 1L)
  expect_equal(e$records[[1]]$url, "https://example.com/a.tif")
  expect_equal(e$records[[1]]$fn,  "prepInputs")
  expect_equal(e$records[[1]]$cacheId, "abc")

  ## Different cacheId -> new record.
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/a.tif",
                               cacheId = "DIFFERENT")
  expect_length(e$records, 2L)
})

test_that("urlLog: preProcess head labels caller as 'prepInputs' when .tempPath supplied", {
  testInit()
  withr::local_options(reproducible.urlLog = TRUE)
  clearUrlLog()

  ## Direct preProcess() call -> .tempPath missing -> labelled "preProcess"
  ## (we exercise this without network by stubbing as a minimal recorder
  ## that mirrors what the real preProcess head does.)
  fakePreProcess <- function(url, destinationPath = ".", .tempPath) {
    reproducible:::.logUrlAccess(
      if (missing(.tempPath)) "preProcess" else "prepInputs",
      url, destinationPath = destinationPath)
  }

  fakePreProcess(url = "https://example.com/a.tif")
  fakePreProcess(url = "https://example.com/b.tif", .tempPath = tempdir())

  log <- prepInputsLog()
  expect_length(log, 2L)
  expect_equal(log[[1]]$fn, "preProcess")
  expect_equal(log[[2]]$fn, "prepInputs")
})

test_that("urlLog: function callback sink invoked with each record", {
  testInit()
  collected <- list()
  cb <- function(rec) collected[[length(collected) + 1L]] <<- rec
  withr::local_options(reproducible.urlLog = cb)
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/a.tif")
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/b.tif")
  expect_length(collected, 2L)
  expect_equal(collected[[1]]$url, "https://example.com/a.tif")
})

test_that("urlLog: NULL url is ignored", {
  testInit()
  withr::local_options(reproducible.urlLog = TRUE)
  clearUrlLog()
  reproducible:::.logUrlAccess("prepInputs", NULL)
  reproducible:::.logUrlAccess("prepInputs", character(0))
  expect_length(prepInputsLog(), 0L)
})

test_that("urlLog: idempotency key handles NA cacheId", {
  testInit()
  e <- new.env(parent = emptyenv())
  withr::local_options(reproducible.urlLog = e)
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/a.tif",
                               cacheId = NA_character_)
  reproducible:::.logUrlAccess("prepInputs", "https://example.com/a.tif",
                               cacheId = NA_character_)
  expect_length(e$records, 1L)
})

test_that("urlLog: Cache(Map(...prepInputs(url=url))) attaches urls via frame on miss + replays on hit", {
  testInit("terra")
  withr::local_options(reproducible.cachePath = tmpdir)
  e <- new.env(parent = emptyenv())
  withr::local_options(reproducible.urlLog = e)

  urls <- c("https://example.com/a.tif", "https://example.com/b.tif")

  ## Stub prepInputs that calls the real function-head hook, so the frame
  ## mechanism gets exercised without touching the network.
  fakePrepInputs <- function(url, destinationPath = ".") {
    reproducible:::.logUrlAccess("prepInputs", url,
                                 destinationPath = destinationPath)
    url
  }
  prepInputs <- fakePrepInputs

  ## First call: cache miss. Inner stub fires hook -> urls pushed to Cache
  ## frame -> Cache attaches tags + emits session records on save.
  r1 <- Cache(Map(url = urls, function(url) prepInputs(url = url)))

  expect_length(e$records, 2L)
  cids <- unique(vapply(e$records, function(r) r$cacheId, character(1)))
  expect_length(cids, 1L)
  expect_setequal(vapply(e$records, function(r) r$url, character(1)), urls)

  sc <- showCache(tmpdir, cacheId = cids)
  expect_true("reproducible.url"          %in% sc$tagKey)
  expect_true("reproducible.urlHitCount"  %in% sc$tagKey)

  ## Second call: cache hit. Fresh env -> replay from DB tags.
  e2 <- new.env(parent = emptyenv())
  withr::local_options(reproducible.urlLog = e2)
  r2 <- Cache(Map(url = urls, function(url) prepInputs(url = url)))

  expect_length(e2$records, 2L)
  expect_setequal(vapply(e2$records, function(r) r$url, character(1)), urls)

  sc2 <- showCache(tmpdir, cacheId = cids)
  hc <- as.integer(sc2$tagValue[sc2$tagKey == "reproducible.urlHitCount"])
  expect_true(any(hc >= 1L))
})

test_that("urlLog: Cache(Map(..., function(url) prepInputs(url=url))) does not error", {
  testInit("terra")
  withr::local_options(
    reproducible.urlLog   = TRUE,
    reproducible.cachePath = tmpdir
  )
  clearUrlLog()

  ## Mask prepInputs locally with a stub that invokes the real hook
  ## (so the frame mechanism gets exercised).
  fakePrepInputs <- function(url, destinationPath = ".") {
    reproducible:::.logUrlAccess("prepInputs", url,
                                 destinationPath = destinationPath)
    url
  }
  prepInputs <- fakePrepInputs
  urls <- c("https://example.com/a.tif", "https://example.com/b.tif")

  expect_no_error({
    Cache(Map(url = urls, function(url) prepInputs(url = url)))
  })
})

test_that("urlLog: Cache hooks tag cacheId with reproducible.url* tags", {
  testInit("terra", needInternet = FALSE)
  withr::local_options(
    reproducible.urlLog   = TRUE,
    reproducible.cachePath = tmpdir
  )
  clearUrlLog()

  ## Drive the Cache hooks via a synthetic call that does NOT touch the network:
  ## the stub invokes the real function-head hook so the frame mechanism
  ## carries the URL into the Cache tag-write path.
  fakePrepInputs <- function(url, destinationPath = ".") {
    reproducible:::.logUrlAccess("prepInputs", url,
                                 destinationPath = destinationPath)
    "ok"
  }
  prepInputs <- fakePrepInputs

  out1 <- Cache(prepInputs(url = "https://example.com/a.tif"))
  out2 <- Cache(prepInputs(url = "https://example.com/a.tif"))  # hit
  expect_equal(as.character(out1), "ok")
  expect_equal(as.character(out2), "ok")

  sc <- showCache(tmpdir, userTags = "reproducible.url")
  expect_true(NROW(sc) > 0L)
  expect_true("reproducible.url"          %in% sc$tagKey)
  expect_true("reproducible.urlFn"        %in% sc$tagKey)
  expect_true("reproducible.urlFirstSeen" %in% sc$tagKey)
  expect_true("reproducible.urlLastSeen"  %in% sc$tagKey)
  expect_true("reproducible.urlHitCount"  %in% sc$tagKey)

  ## hitCount should be >= 1 after the second (hit) call
  hc <- as.integer(sc$tagValue[sc$tagKey == "reproducible.urlHitCount"])
  expect_true(any(hc >= 1L))

  ## Session log: miss + subsequent hit dedup to one record per cacheId.
  log <- prepInputsLog()
  expect_length(log, 1L)
})

test_that("urlLog: legacy cache hit (no tags) recovers url from matched call + self-heals", {
  testInit("terra")
  withr::local_options(reproducible.cachePath = tmpdir)

  fakePrepInputs <- function(url, destinationPath = ".") "ok"
  prepInputs <- fakePrepInputs

  ## Create a "legacy" entry with the feature OFF -> no reproducible.url* tags.
  withr::local_options(reproducible.urlLog = FALSE)
  invisible(Cache(prepInputs(url = "https://example.com/legacy.tif")))
  sc0 <- showCache(tmpdir, userTags = "reproducible.url")
  expect_equal(NROW(sc0), 0L)   # confirm no url tags yet

  ## Now turn the feature on (default) and hit the same entry. Option 1 should
  ## recover the url from the matched call, emit a record, and back-fill tags.
  withr::local_options(reproducible.urlLog = TRUE)
  clearUrlLog()
  out <- Cache(prepInputs(url = "https://example.com/legacy.tif"))  # hit
  expect_equal(as.character(out), "ok")

  log <- prepInputsLog()
  expect_length(log, 1L)
  expect_equal(log[[1]]$url, "https://example.com/legacy.tif")

  ## Self-heal: tags now exist, so a further hit replays from the DB.
  sc1 <- showCache(tmpdir, userTags = "reproducible.url")
  expect_true("reproducible.url" %in% sc1$tagKey)
  expect_true(any(sc1$tagValue == "https://example.com/legacy.tif"))
})