Nothing
## Convert a specification for an endpoint into an R function that o
swagger_args <- function(method, path, x, handlers, types, spec) {
args <- swagger_args_parse(method, path, x, spec)
help <- swagger_args_help(x, args, handlers)
list(help = help,
handler = swagger_args_handler(args, handlers, types))
}
swagger_args_parse <- function(method, path, x, spec) {
args <- x$parameters
if (is.null(args)) {
return(NULL)
}
args_in <- vcapply(args, "[[", "in")
is_body <- args_in == "body"
if (any(is_body)) {
stopifnot(sum(is_body) == 1L)
i_body <- which(is_body)
body <- args[[i_body]]
body$schema <- resolve_schema_ref(body$schema, spec)
if (body$schema$type == "object") {
description <- tolower1(body$description) %||% "request body"
to_par <- function(x) {
el <- resolve_schema_ref(body$schema$properties[[x]], spec)
el$description <- el$description %||% paste("For", description)
c(list(name = x, "in" = "body"), el)
}
args_body <- lapply(names(body$schema$properties), to_par)
i1 <- seq_len(i_body - 1L)
i2 <- setdiff(seq_along(args), c(i1, i_body))
args <- c(args[i1], args_body, args[i2])
args_in <- c(args_in[i1], rep("body", length(args_body)), args_in[i2])
body_type <- "combine"
} else {
## here, body$schema$type == "string"
body_type <- "single"
p <- args[[i_body]]
args[[i_body]] <- c(p[names(p) != "schema"], p$schema)
}
} else {
body_type <- NULL
}
args_name <- vcapply(args, "[[", "name")
args_name_r <- args_name
args_name_r[args_in == "header"] <-
x_kebab_to_snake(args_name[args_in == "header"])
args_name_r <- pascal_to_snake_cached(args_name_r)
for (i in seq_along(args)) {
args[[i]]$name_r <- args_name_r[[i]]
args[[i]] <- resolve_schema_ref(args[[i]], spec)
}
if (any(duplicated(args_name)) || any(duplicated(args_name_r))) {
stop("fix duplicated names") # nocov [stevedore bug]
}
stopifnot(identical(args_name[args_in == "path"],
swagger_path_parse(path)$args))
i <- match(args_in, c("path", "body", "query", "header"))
stopifnot(all(!is.na(i)))
args_req <- vlapply(args, function(x) isTRUE(x$required))
args <- args[order(!args_req, i)]
attr(args, "body_type") <- body_type
args
}
swagger_args_handler <- function(args, handlers, types) {
## All the stopifnot bits are assertions that have more to do with
## making sure that the spec confirms to what we are expecting.
## They'd probably be better done with debugme because I don't think
## they should be run by users.
dest <- quote(dest)
env <- new.env(parent = parent.env(environment()))
if (!is.null(handlers)) {
stopifnot(names(handlers) %in% vcapply(args, "[[", "name_r"))
handler_fns <- lapply(handlers, function(x) types[[x]]$handler)
names(handler_fns) <- handler_name(names(handler_fns))
list2env(handler_fns, env)
handlers[] <- names(handler_fns)
}
body_type <- attr(args, "body_type")
if (is.null(body_type)) {
fbody_body_combine <- NULL
} else {
if (body_type == "combine") {
fbody_body_combine <-
as_call(quote(jsonlite::toJSON), dollar(dest, quote(body)))
} else if (body_type == "single") {
## We'd be better off doing this within the core body function
## probably but that requires a bit of faff.
nm <- as.symbol(args[[which(vcapply(args, "[[", "in") == "body")]]$name)
fbody_body_combine <- dollar(dest, quote(body), nm)
}
fbody_body_combine <- bquote(
.(dollar(dest, quote(body))) <- .(fbody_body_combine))
}
fbody_collect <- lapply(args, swagger_arg_collect, dest, handlers)
fbody <- c(quote(`{`),
bquote(.(dest) <- list()),
fbody_collect,
fbody_body_combine,
dest)
args_optional <- !vlapply(args, function(x) isTRUE(x$required))
args_name_r <- vcapply(args, "[[", "name_r")
a <- rep(alist(. =, . = NULL), c(sum(!args_optional), sum(args_optional)))
names(a) <- args_name_r
as.function(c(a, as.call(fbody)), env)
}
## The actual argument collectors (used only in this file)
swagger_arg_collect <- function(p, dest, handlers) {
switch(p[["in"]],
path = swagger_arg_collect_path(p, dest),
query = swagger_arg_collect_query(p, dest),
body = swagger_arg_collect_body(p, dest, handlers),
header = swagger_arg_collect_header(p, dest),
stop("assertion error [stevedore bug]"))
}
swagger_arg_collect_path <- function(p, dest) {
if (!isTRUE(p$required)) {
stop("all path parameters assumed required") # nocov [stevedore bug]
}
rhs <- as_call(quote(assert_scalar_character), as.symbol(p$name_r))
lhs <- dollar(dest, quote(path), as.symbol(p$name))
as_call(quote(`<-`), lhs, rhs)
}
## some of the 'query' bits within here must change - we might need to
## construct different validators depending on what sort of input
## we're getting? It might be better to realise that avoiding
## duplication here is just making this function worse, not better!
swagger_arg_collect_query <- function(p, dest) {
type <- p$type
stopifnot(length(type) == 1L)
if (type == "boolean") {
validate <- quote(assert_scalar_logical)
} else if (type == "integer") {
validate <- quote(assert_scalar_integer)
} else if (type == "string") {
if (isTRUE(p$multiple)) {
validate <- quote(assert_nonempty_character)
} else {
validate <- quote(assert_scalar_character)
}
} else if (type == "array") {
stop("Unknown array query type [stevedore bug]")
} else {
stop("Unknown query type [stevedore bug]")
}
nm <- as.symbol(p$name)
nm_r <- as.symbol(p$name_r)
rhs <- as_call(validate, nm_r)
lhs <- dollar(dest, quote(query), nm)
expr <- as_call(quote(`<-`), lhs, rhs)
if (!isTRUE(p$required)) {
expr <- bquote(if (!is.null(.(nm_r))) .(expr))
}
expr
}
## This is really similar to above but not *that* similar really -
## when combined they're clumsy and hard to reason about.
swagger_arg_collect_body <- function(p, dest, handlers) {
type <- p$type
if (p$name_r %in% names(handlers)) {
is_scalar <- FALSE
validate <- as.name(handlers[[p$name_r]])
} else if (setequal(type, c("array", "string"))) {
is_scalar <- FALSE
validate <- quote(as_body_array_string)
} else if (type == "boolean") {
validate <- quote(assert_scalar_logical)
is_scalar <- TRUE
} else if (type == "integer") {
validate <- quote(assert_scalar_integer)
is_scalar <- TRUE
} else if (type == "string") {
if (identical(p$format, "binary")) {
validate <- quote(assert_raw)
is_scalar <- FALSE
} else {
validate <- quote(assert_scalar_character)
is_scalar <- TRUE
}
} else if (type == "array") {
if (identical(p$items$type, "string")) {
## Env, OnBuild Shell, Cmd, DeviceCgroupRules
validate <- quote(assert_character)
} else {
## TODO: Some of these do have specs so could be done totally
## automatically. But then doing it that way requires the user
## to guess how the mapping has been done. So a simpler way
## might be to have a 'types' element in the main docker_client
## object that can produce appropriate types. Then here we just
## feed things through. Eventually it would be good to validate
## all things that come through here though.
##
## BlkioWeightDevice, BlkioDeviceReadBps, BlkioDeviceWriteBps,
## BlkioDeviceReadIOps, BlkioDeviceWriteIOps (last four are all
## ThrottleDevice types)
##
## Devices, Ulimits
validate <- quote(identity)
}
is_scalar <- FALSE
} else {
if (identical(p$additionalProperties, list(type = "string"))) {
## Labels, Options, DriverOpts
validate <- quote(as_string_map)
} else {
## Processed elsewhere:
##
## ExposedPorts, Volumes
##
## Not yet explicitly handled:
##
## Healthcheck, HostConfig, NetworkingConfig, RestartPolicy,
## IPAM, EndpointConfig,
validate <- quote(identity)
}
is_scalar <- FALSE
}
nm <- as.symbol(p$name)
nm_r <- as.symbol(p$name_r)
rhs <- as_call(validate, nm_r)
if (is_scalar) {
rhs <- as_call(quote(jsonlite::unbox), rhs)
}
lhs <- dollar(dest, quote(body), nm)
expr <- as_call(quote(`<-`), lhs, rhs)
if (!isTRUE(p$required)) {
expr <- bquote(if (!is.null(.(nm_r))) .(expr))
}
expr
}
swagger_arg_collect_header <- function(p, dest) {
stopifnot(p$type == "string")
nm <- p$name_r
sym <- as.name(nm)
is_required <- isTRUE(p$required)
has_default <- !is.null(p$default)
if (is.null(p$enum)) {
expr <- bquote(assert_scalar_character(.(sym)))
} else {
values <- as_call(quote(c), p$enum)
expr <- bquote(match_value(.(sym), .(values)))
}
if (!is_required && has_default) {
expr <- bquote(if (is.null(.(sym))) .(p$default) else .(expr))
}
expr <- bquote(.(dest)$header[[.(p$name)]] <- .(expr))
if (!is_required) {
expr <- bquote(if (!is.null(.(sym))) .(expr))
}
expr
}
swagger_args_help <- function(x, args, handlers) {
if (length(args) == 0L) {
args <- NULL
} else {
args <- set_names(vcapply(args, pick, "description", NA_character_),
vcapply(args, "[[", "name_r"))
}
if (!is.null(handlers)) {
str <- sprintf(" Construct with `$types$%s()`",
vcapply(handlers, identity))
args[names(handlers)] <- paste0(args[names(handlers)], str)
}
list(summary = x$summary, description = x$description, args = args)
}
as_body_array_string <- function(x, name = deparse(substitute(x))) {
assert_character(x, name)
x
}
## For objects in the yaml that follow:
##
## type: "object"
## additionalProperties:
## type: "string"
##
## Used in Labels, Options, DriverOpts
as_string_map <- function(x, name = deparse(substitute(x))) {
if (!is.null(x)) {
what <- "named character vector"
assert_named(x, TRUE, name, what)
assert_character(x, name, what)
lapply(x, jsonlite::unbox)
}
}
handler_name <- function(x) {
sprintf(".handle_%s", x)
}
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.