Nothing
run_sample_responses <- function(obj) {
for (x in obj$endpoints) {
run_sample_response(x, obj$spec)
}
}
run_sample_response <- function(x, spec) {
responses <- spec$paths[[x$path]][[tolower(x$method)]]$responses
message(sprintf("%s %s", toupper(x$method), x$path))
ret <- vector("list", length(responses))
names(ret) <- names(responses)
for (code in names(responses)) {
if (as.integer(code) < 300) {
found_example <- FALSE
response <- responses[[code]]
response$schema <- resolve_schema_ref(response$schema, spec)
ex <- response[["schema"]][["example"]]
if (!is.null(ex)) {
found_example <- TRUE
message(crayon::blue(" - ", code))
testthat::expect_silent(
ret[[code]] <- x$response_handlers[[code]](ex, FALSE))
}
ex <- response[["examples"]]
if (!is.null(ex)) {
found_example <- TRUE
message(crayon::blue(" - ", code))
for (e in ex) {
testthat::expect_silent(
ret[[code]] <- x$response_handlers[[code]](e, FALSE))
}
}
if (!found_example) {
message(crayon::red(" - (no example)"))
}
}
}
invisible(ret)
}
describe_api <- function(x) {
endpoints <- lapply(x$spec$paths, names)
tag <- lapply(x$spec$paths, vcapply, function(el) el$tags %||% NA_character_)
n <- lengths(endpoints)
stopifnot(all(lengths(tag) == n))
info <- data.frame(method = unname(unlist(endpoints, FALSE)),
path = rep(names(endpoints), n),
tag = unname(unlist(tag, FALSE)),
stringsAsFactors = FALSE)
ours <- data.frame(method = vcapply(x$endpoints, "[[", "method",
USE.NAMES = FALSE),
path = vcapply(x$endpoints, "[[", "path",
USE.NAMES = FALSE),
stringsAsFactors = FALSE)
p <- function(x) {
paste(toupper(x$method), x$path, sep = " ")
}
info$included <- p(info) %in% p(ours)
msg <- info[!info$included, ]
msg <- split(p(msg), msg$tag)
all <- split(p(info), info$tag)
for (i in names(msg)) {
message(sprintf("%s:", i))
if (length(msg[[i]]) == length(all[[i]])) {
message(" (none implemented)")
} else {
message(paste(sprintf(" - %s", msg[[i]]), collapse = "\n"))
}
}
invisible(info)
}
read_sample_response <- function(path) {
ret <- read_sample_response_header(path)
spec <- swagger_spec_read(ret$version)
endpoint <- spec$paths[[ret$path]][[ret$method]]
ret$schema <- endpoint$responses[[ret$code]]
ret$produces <- get_response_type(ret$method, ret$path, endpoint)
ret$handler <- swagger_response_handler(ret$schema, spec, ret$produces)
ret$reference <- eval(parse(text = ret$txt))
ret
}
read_sample_response_header <- function(path) {
txt <- readLines(path)
response_json <- sub("\\.R$", ".json", path)
if (file.exists(response_json)) {
response <- readChar(response_json, file.size(response_json))
} else {
response <- NULL
}
ret <- parse_sample_response(txt, response)
if (ret$response == "~") {
ret$response <- raw()
} else {
ret$response <- charToRaw(ret$response)
}
ret$txt <- txt
ret
}
parse_sample_response <- function(txt, response) {
i <- grep("^[^#]", txt)[[1]]
head <- sub("^#+\\s*", "", txt[seq_len(i - 1L)])
re <- "(^[^ ]+): +(.*)\\s*$"
stopifnot(all(grepl(re, head)))
value <- sub(re, "\\2", head)
ret <- set_names(as.list(value), sub(re, "\\1", head))
if (!is.null(response)) {
ret$response <- response
}
msg <- setdiff(c("version", "method", "path", "code", "response"), names(ret))
if (length(msg) > 0L) {
stop(sprintf("Missing expected fields %s", paste(msg, collapse = ", ")))
}
ret$method <- tolower(ret$method)
ret
}
read_sample_response_str <- function(method, path, code, spec, error = TRUE) {
r <- spec$paths[[path]][[tolower(method)]]$responses[[as.character(code)]]
to_str <- function(x) jsonlite::toJSON(x, auto_unbox = TRUE)
schema <- resolve_schema_ref(r$schema, spec)
ex <- schema[["example"]]
if (!is.null(ex)) {
return(to_str(ex))
}
ex <- r[["examples"]]
if (!is.null(ex)) {
return(to_str(ex[[1]]))
}
ex <- r[["schema"]][["example"]]
if (!is.null(ex)) {
return(to_str(ex))
}
if (identical(r$schema$type, "array")) {
r$schema$items <- resolve_schema_ref(r$schema$items, spec)
ex1 <- r$schema$items$example
if (!is.null(ex1)) {
return(to_str(list(ex1)))
}
}
msg <- sprintf("did not find example for %s %s", method, path)
if (error) {
stop(msg)
} else {
message(msg)
}
NULL
}
dput2 <- function(x) {
paste(capture.output(dput(x)), collapse = "\n")
}
dput_list <- function(obj) {
tmp <- vcapply(obj, dput2)
els <- paste(sprintf(" %s = %s", names(tmp), unname(tmp)), collapse = ",\n")
sprintf("list(\n%s\n )", els)
}
dput_cvec <- function(x) {
els <- paste(sprintf(' %s = "%s"', names(x), unname(x)), collapse = ",\n")
sprintf("c(\n%s\n )", els)
}
add_sample_response <- function(filename, method, path, code, version,
error = FALSE) {
if (file.exists(filename)) {
if (error) {
stop("filename already exists")
}
}
spec <- swagger_spec_read(version)
response <- read_sample_response_str(method, path, code, spec, error)
if (is.null(response)) {
return(invisible())
}
dat <- list(version = version, method = method, path = path, code = code,
response = response)
txt <- c(sprintf("## %s: %s", names(dat), unname(dat)), "NULL")
writeLines(txt, filename)
}
rand_str <- function(n, prefix = "") {
paste0(prefix, paste0(sample(letters, n, replace = TRUE), collapse = ""))
}
random_hex <- function(n, prefix = "") {
pool <- c(as.character(0:9), letters[1:6])
paste0(prefix, paste0(sample(pool, n, replace = TRUE), collapse = ""))
}
get_error <- function(expr) {
tryCatch(expr, error = identity)
}
## TODO: at some point a variant of this will move into the main
## constructor, with a proper error message advising on solutions.
## But I think that this is updated with curl version so could just
## come out surely?
CURL_HAS_SOCKET_SUPPORT <-
!inherits(try(curl::curl_options()[["unix_socket_path"]], silent = TRUE),
"try-error")
skip_if_no_curl_socket <- function() {
if (!CURL_HAS_SOCKET_SUPPORT) {
testthat::skip("libcurl does not have support for unix sockets")
}
}
null_docker_client <- function(...) {
docker_client(..., http_client_type = "null", ignore_environment = TRUE)
}
has_internet <- function() {
!is.null(suppressWarnings(utils::nsl("www.google.com")))
}
skip_if_no_internet <- function() {
skip_on_cran()
skip_on_windows()
if (has_internet()) {
return()
}
testthat::skip("no internet")
}
skip_if_no_httppipe_support <- function() {
skip("httppipe needs update for new python/reticulate")
skip_on_cran()
if (!httppipe_available()) {
testthat::skip("httppipe support not possible")
}
}
test_sample_responses <- function(v, skip = NULL) {
files <- dir(file.path("sample_responses", paste0("v", v)),
pattern = "\\.R$", full.names = TRUE)
for (file in files) {
base <- sub("\\.R$", "", basename(file))
testthat::test_that(sprintf("sample_responses: v%s - %s", v, base), {
if (base %in% skip) {
testthat::skip("not yet working")
}
dat <- read_sample_response(file)
opts1 <- list(as_is_names = FALSE, data_frame = identity)
opts2 <- list(as_is_names = TRUE, data_frame = identity)
ans1 <- dat$handler(dat$response, opts1)
ans2 <- dat$handler(dat$response, opts2)
testthat::expect_equal(ans1, dat$reference)
testthat::expect_equal(ans2, dat$reference, check.attributes = FALSE)
})
}
res <- audit_spec_response(v)
testthat::expect_false(any(res$missing))
}
create_sample_responses <- function(target, base) {
path_base <- file.path("sample_responses", paste0("v", base))
path_target <- file.path("sample_responses", paste0("v", target))
spec <- swagger_spec_read(target)
files <- dir(path_base, "\\.R$", full.names = TRUE)
re_fmt <- "^(#+ %s:\\s*)(.+)\\s*$"
f <- function(filename) {
x <- readLines(filename)
re_version <- sprintf(re_fmt, "version")
i <- grep(re_version, x)
stopifnot(length(i) == 1L)
x[[i]] <- paste0(sub(re_version, "\\1", x[[i]]), target)
response_json <- sub("\\.R$", ".json", filename)
if (file.exists(response_json)) {
response_prev <- readChar(response_json, file.size(response_json))
} else {
response_prev <- NULL
}
d <- parse_sample_response(x, response_prev)
response <- read_sample_response_str(d$method, d$path, d$code, spec, FALSE)
if (is.null(response)) {
if (d$response == "~") {
response <- "~"
} else {
response <- "<fill me in>"
}
}
## Special casing required for ping which is the only tested plain
## text endpoint.
if (d$path == "/_ping") {
response <- from_json(response)
}
re_response <- sprintf(re_fmt, "response")
i <- grep(re_response, x)
if (length(i) > 0L) {
stopifnot(length(i) == 1L)
x[[i]] <- paste0(sub(re_response, "\\1", x[[i]]), response)
} else {
re_code <- sprintf(re_fmt, "code")
i <- grep(re_code, x)
stopifnot(length(i) == 1L)
x <- append(x, paste("## response:", response), i)
}
x
}
dir.create(path_target, FALSE, TRUE)
for (filename in files) {
dest <- file.path(path_target, basename(filename))
if (file.exists(dest)) {
message(sprintf("Destination %s exists - skipping", dest))
next
}
res <- f(filename)
if (!is.null(res)) {
writeLines(res, dest)
}
}
}
repeat_until_error <- function(fn, times = 10L, interval = 0.1) {
for (i in seq_len(times)) {
e <- get_error(fn())
if (is_error(e)) {
return(e)
} else {
Sys.sleep(0.1)
}
}
stop("Did not throw error in time")
}
fake_pager <- function(dest) {
force(dest)
function(files, header, title, delete.file) {
file.copy(files, dest)
if (delete.file) {
unlink(files)
}
}
}
skip_on_windows <- function() {
testthat::skip_on_os("windows")
}
make_fake_files <- function(paths) {
root <- tempfile_test()
paths <- file.path(root, paths)
for (d in unique(dirname(paths))) {
dir.create(d, FALSE, TRUE)
}
for (p in grep("/$", paths, invert = TRUE, value = TRUE)) {
file.create(p)
}
root
}
get_stevedorebot_pass <- function() {
pw <- Sys.getenv("STEVEDORE_STEVEDOREBOT_PASS", "")
if (!nzchar(pw)) {
testthat::skip("'STEVEDORE_STEVEDOREBOT_PASS' is not defined")
}
pw
}
set_dummy_id <- function(value) {
prev <- .stevedore$dummy_id
.stevedore$dummy_id <- value
invisible(prev)
}
update_dummy_attrs <- function(object, value) {
object$.attrs[names(value)] <- value
invisible(object)
}
update_name_cache <- function(root) {
testthat::test_file(file.path(root, "tests/testthat/test-help.R"))
names <- .stevedore$names
names <- names[order(names[, 1L]), ]
ex <- read.csv(file.path(root, "inst/spec/names_override.csv"),
stringsAsFactors = FALSE)
i <- match(ex$from, names[, 1L])
stopifnot(!any(is.na(i)))
names[i, "to"] <- ex$to
write.csv(names, file.path(root, "inst/spec/names.csv"), row.names = FALSE)
invisible(names)
}
audit_spec_response <- function(v) {
endpoints <- docker_api_client_endpoints()
produces <- function(x, spec) {
d <- spec$paths[[x$path]][[x$method]]
type <- get_response_type(x$method, x$path, d)
if (type == "application/json") {
response <- d$responses[as.integer(names(d$responses)) < 300][[1]]
if (is.null(resolve_schema_ref(response$schema, spec))) {
type <- "null"
}
}
type
}
spec <- swagger_spec_read(DOCKER_API_VERSION_MAX)
produces <- vcapply(endpoints, produces, spec)
files <- dir(sprintf("sample_responses/v%s", v), pattern = "\\.R$",
full.names = TRUE)
tmp <- lapply(files, read_sample_response_header)
ok <- vcapply(tmp, "[[", "version") == v
if (!all(ok)) {
stop(sprintf("Response has wrong version: %s",
paste(files[!ok], collapse = ", ")))
}
p1 <- vcapply(endpoints, function(x) paste(tolower(x$method), x$path))
p2 <- vcapply(tmp, function(x) paste(tolower(x$method), x$path))
tested <- p1 %in% p2
supported <-
numeric_version(vcapply(endpoints, function(x) x$from %||% "0.0.0")) <= v
ret <- data_frame(method = vcapply(endpoints, "[[", "method"),
path = vcapply(endpoints, "[[", "path"),
supported = supported,
produces = produces,
tested = tested)
exclude <- c("post /build", "post /images/create", "post /images/load",
"post /plugins/pull")
ret$missing <-
ret$supported & ret$produces == "application/json" & !ret$tested &
!(paste(ret$method, ret$path) %in% exclude)
ret
}
fake_tls_dir <- function() {
path <- tempfile_test()
dir.create(path)
files <- c("key.pem", "ca.pem", "cert.pem")
for (p in files) {
file.create(file.path(path, p))
}
path
}
wait_until_ready <- function(f, times = 10, period = 0.5) {
for (i in seq_len(times)) {
dat <- tryCatch(f(), error = function(e) FALSE)
if (isTRUE(dat)) {
return(invisible())
}
Sys.sleep(period)
}
stop("Not ready in time")
}
try_silent <- function(expr) {
tryCatch(expr, error = function(e) NULL)
}
wait_until_container_gone <- function(container) {
f <- function() {
is.null(tryCatch(container$status(), error = function(e) NULL))
}
wait_until_ready(f, 100, 0.1)
}
stop_service_and_wait_until_service_container_gone <- function(service) {
tasks <- service$tasks()
cl <- service$.parent
containers <- lapply(tasks, function(x)
tryCatch(cl$container$get(x$inspect()$status$container_status$container_id),
error = function(e) NULL))
service$remove()
for (x in containers) {
if (!is.null(x)) {
wait_until_container_gone(x)
}
}
}
## Untar a raw vector
untar_bin <- function(bin, path = tempfile_test(), ...) {
tmp <- tempfile_test()
writeBin(bin, tmp)
on.exit(unlink(tmp))
dir.create(path, FALSE, TRUE)
utils::untar(tmp, exdir = path, ...)
invisible(path)
}
tempfile_test <- function(tmpdir = tempdir(), fileext = "") {
tempfile("stevedore_test", tmpdir, fileext)
}
cleanup_tempdir <- function() {
files <- dir(tempdir(), pattern = "^stevedore_test_", full.names = TRUE)
unlink(files, recursive = TRUE)
}
fake_docker_machine <- function(env, path = tempfile()) {
dir.create(path, FALSE, TRUE)
dest <- file.path(path, "docker-machine")
code <- c(
"#!/usr/bin/env bash",
sprintf('echo \'export %s="%s"\'', names(env), unname(env)))
writeLines(code, dest)
Sys.chmod(dest, "755")
path
}
dummy_data_frame_wrapper <- function(x) {
class(x) <- c("extra", class(x))
x
}
skip_if_external_tar_unsupported <- function() {
testthat::skip_on_os("solaris")
testthat::skip_on_cran()
if (tolower(Sys.info()[["sysname"]]) == "solaris") {
testthat::skip("Stevedore does not support this tar")
}
}
capture_output_no_crayon <- function(code) {
withr::with_options(
list(crayon.enabled = FALSE),
capture.output(force(code)))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.