R/servicetests.R

In avantcredit/servicetests: R Service Tests (http://github.com/khalidharun/r-test-api-services)

.servicetests_env <- new.env()
.servicetests_env$reg <- list()

#' Set cache root
#'
#' @param cache_root directory. Path to where cache will be saved.
#' @export
set_cache_root <- function(cache_root = getOption("servicetests.dir", "~/.R/servicetests")) {
  .servicetests_env$registry <- director::registry$new(cache_root)
}


#' Get path to where the registry cache is stored
#'
#' @export
get_cache_root <- function() { .servicetests_env$registry$.root }


#' Generate a hash for internal use
#' @param obj list. An object to hash
generate_hash <- function(obj) {
  digest::digest(obj)
}


#' Get all the registered service tests
#' @export
get_registered_keys <- function() {
  reg <- get_registry()
  lapply(reg, function(x) x$hash)
}


#' Unregister a service call and returns TRUE if registry was updated.
#'
#' Remove a test identified by it's key
#'
#' @param key character. Registered key to remove
#' @export
unregister_service_call <- function(key) {
  if (!(exists(key, get_registry()))) return(FALSE)
  .servicetests_env$reg[[key]] <- NULL
  TRUE
}

#' Register a service call
#'
#' When a call is registered, it will be tested periodically to make
#' sure that service calls don't break.
#'
#' @param key character. Unique identifier.
#' @param sfn call. Quoted call to register.
#' @param envir environment. The enviroment where the call is evaluated.
#' @param force logical. If TRUE, it will overwrite any servicetest already registered to the key.
#' @export
register_service_call <- function(key, sfn, envir = parent.frame(1), force = FALSE) {
  if (missing(key)) stop("No key provided.")
  if (missing(sfn)) stop("No service call provided.")

  sfn <- if (identical("call", class(sfn))) sfn else substitute(sfn)

  match_fn <- NULL

  if (identical("list", deparse(sfn[[1]]))) {
    arg_names <- c("", "call", "match_fn")
    if (!identical(arg_names, names(sfn))) stop("A service call must be a named list with in the format list(call = fn(x,y), match_fn = all.equal.custom)")
    match_fn <- deparse(sfn[["match_fn"]])
    sfn <- sfn[["call"]]
  }

  fname <- deparse(sfn[[1]])
  params <- lapply(sfn[-1], eval, envir)
  hash <- generate_hash(c(params, fname))

  reg <- .servicetests_env$reg

  if (exists(key, reg)) {
    if (identical(force, FALSE)) {
      warning("Service call is already registered. Set 'force = TRUE' to replace service call.")
      return(FALSE)
    }
  }

  tryCatch({
    response <- eval(sfn, envir)
  }, error = function(e) {
    message(paste0("Error caught trying to register ", key, ": ", e$message))
    return(FALSE)
  })

  .servicetests_env$reg[[key]] <- list(
    key = key,
    fname = fname,
    params = params,
    hash = hash,
    match_fn = match_fn,
    expected = response
  )
  TRUE
}

#' register a list of service calls
#' @param call_list lanuage. The service calls to register.
#' @param envir environment. The environment where the service call is evaluated.
#' @param ... calls passed in named arguments.
register_service_calls <- function(call_list = list(), envir = parent.frame(1), ...) {
  calls <- if (missing(call_list)) list() else lapply(call_list[-1], function(x) x)
  calls <- append(calls, eval(substitute(alist(...))))
  keys <- names(calls)

  keys_registered <- names(get_registry())
  keys_removed <- setdiff(keys_registered, keys)

  lapply(seq_along(calls), function(i) {
    register_service_call(names(calls)[[i]], calls[[i]], envir = envir, force = TRUE);
  })

  # Remove keys
  lapply(keys_removed, function(x) {
    unregister_service_call(x);
  })

}

#' Test each service that is registered
#'
#' @param obj list. Is the registered service call and response to test.
#' @param envir environment. The environment where the service is called from.
#' @param on.pass_each function. Callback function when a test passes.
#' @param on.fail_each function. Callback function when a test fails.
test_service <- function(obj, envir = parent.frame(), on.pass_each = NULL, on.fail_each = NULL) {
  if (!is.null(on.fail_each) && !is.function(on.fail_each)) stop("on.fail_each must be a function.")
  if (!is.null(on.pass_each) && !is.function(on.pass_each)) stop("on.pass_each must be a function.")

  result <- tryCatch(
    withCallingHandlers({
      res <- do.call(eval(parse(text = obj$fname), envir = envir), obj$params, envir = envir)
      match_fn <- obj$match_fn %||% 'all.equal'
      passed <- isTRUE(try(do.call(match_fn, list(res, obj$expected)), silent = TRUE))
      list(
        passed = passed,
        actual = res
      )
    }, error = capture_calls), # Capture stack trace on errors.
    error = function(e) {
      list(
        passed = FALSE,
        actual = e
      )
    }
  )
  if (result$passed) {
    if (is.function(on.pass_each)) on.pass_each(obj, result$actual)
  } else {
    if (is.function(on.fail_each)) {
      on.fail_each(obj, result$actual)
    }
  }
  result$passed
}

#' Test registered services
#'
#' @param keys list of characters. If keys are given only those tests will be run.
#' @param return.type character. The return type options are "verbose" or "logical".
#' @param on.pass_all function. Callback function when all tests pass.
#' @param on.fail_any function. Callback function when any tests fail.
#' @param ... any additional arguments to \code{\link{test_service}}.
#' @export
test_service_calls <- function(keys = NULL, return.type = "verbose", on.pass_all = NULL, on.fail_any = NULL, ...) {
  return.type <- match.arg(return.type, c("verbose", "logical"))
  if (!is.null(on.pass_all) && !is.function(on.pass_all)) stop("on.pass_all must be a function.")
  if (!is.null(on.fail_any) && !is.function(on.fail_any)) stop("on.fail_any must be a function.")
  reg <- get_registry()
  if (!missing(keys) && !is.null(keys)) {
    reg <- reg[which(names(reg) %in% keys)]
    if (length(reg) == 0) stop("Key not found")
  }

  output <- lapply(reg, test_service, envir = parent.frame(), ...)

  pass_all <- all(as.logical(output))

  # Trigger callbacks
  if (pass_all) {
    if (is.function(on.pass_all)) on.pass_all()
  } else {
    if (is.function(on.fail_any)) on.fail_any()
  }

  if (identical("verbose", return.type)) return(output)
  if (identical("logical", return.type)) return(pass_all)
}

#' Gets registry that is currently being used.
get_registry <- function() {
  if (!exists('reg', .servicetests_env)) .servicetests_env$reg <- list()
  .servicetests_env$reg
}

#' Clear registry
clear_registry <- function() {
  .servicetests_env$reg <- list()
}


#' Save registry to file
#'
#' @param key character. Key in the cache where registry will be stored
#' @export
save_registry <- function(key = "reg") {
  .servicetests_env$registry$set(key, .servicetests_env$reg)
}


#' Load registry from file
#'
#' @param key character. Key in the cache to load stored registry
#' @export
load_registry <- function(key = "reg") {
  .servicetests_env$reg <- .servicetests_env$registry$get(key)
}

# Initilize a global servicetest registry cache
set_cache_root()