Nothing
## Handlers for the headers are easy because the headers are just
## stringsmapping to fairly simple types - none of these are
## recursive.
swagger_header_handlers <- function(responses, spec) {
responses <- responses[as.integer(names(responses)) < 300]
lapply(responses, swagger_header_handler, spec)
}
swagger_header_handler <- function(response, spec) {
if ("headers" %in% names(response)) {
els <- names(response$headers)
els_r <- x_kebab_to_snake(els)
type <- vcapply(response$headers, "[[", "type")
atomic <- atomic_types()
f_atomic <- function(v, data) {
msg <- atomic$missing[[type[[v]]]]
x <- pick(data, tolower(v), msg)
if (!is.na(x)) {
storage.mode(x) <- storage.mode(msg)
}
x
}
function(headers, output_options) {
h <- parse_headers(headers)
names(h) <- tolower(names(h))
ret <- lapply(els, f_atomic, h)
names(ret) <- if (output_options$as_is_names) els else els_r
ret
}
} else {
NULL
}
}
## This is significantly harder than customising the input; we read
## through the swagger spec and write custom handlers for the json.
## This seems preferable to just relying on the defaults in
## `jsonlite::fromJSON` because things are more likely to be
## type-stable - a zero length array of strings will come out as
## character() and not list(), for example.
##
## There is an existing R package 'rapiclient' for generic swagger
## bindings, but it does not offer hooks that we can use to get just
## the processing part of swagger, and is bound heavily to httr (which
## doesn't work nicely with the unix socket and connection hijacking).
## It also does not handle the spec as provided by docker (it also
## does not have automatically generated handler functions so this
## might be worth pushing upstream).
swagger_response_handlers <- function(responses, spec, produces) {
responses <- responses[as.integer(names(responses)) < 300]
lapply(responses, swagger_response_handler, spec, produces)
}
swagger_response_handler <- function(response, spec, produces) {
binary_types <- c("application/octet-stream",
"application/x-tar",
"application/vnd.docker.raw-stream")
if (produces == "null") {
swagger_response_handler_null(response, spec)
} else if (produces == "application/json") {
swagger_response_handler_json(response, spec)
} else if (produces %in% binary_types) {
swagger_response_handler_binary(response)
} else if (produces == "text/plain") {
swagger_response_handler_text(response)
} else if (produces == "application/chunked-string") {
swagger_response_handler_chunked_string(response)
} else {
stop("Unhandled response type ", produces) # nocov [stevedore bug]
}
}
swagger_response_handler_json <- function(response, spec) {
schema <- resolve_schema_ref(response$schema, spec)
if (is.null(schema)) {
h <- swagger_response_handler_null(schema, spec)
} else if (schema$type == "object") {
h <- swagger_response_handler_object(schema, spec)
} else if (schema$type == "array") {
h <- swagger_response_handler_array(schema, spec)
} else if (schema$type == "string") {
h <- swagger_response_handler_json_string(schema, spec)
} else {
stop("not sure how to make this response handler") # nocov [stevedore bug]
}
function(data, output_options) {
h(raw_to_json(data), output_options)
}
}
swagger_response_handler_null <- function(response, spec) {
function(data, output_options) {
if (length(data) > 0L) {
stop("Expected an empty response") # nocov [stevedore bug]
}
invisible(NULL)
}
}
## This is the slightly odd outcome of /swarm/init, which returns a
## json encoded string
swagger_response_handler_json_string <- function(response, spec) {
function(data, output_options) {
assert_scalar_character(data)
data
}
}
swagger_response_handler_object <- function(schema, spec) {
atomic <- atomic_types()
additional_properties <- additional_properties_handler <- NULL
if (!is.null(schema$additionalProperties)) {
ap <- resolve_schema_ref(schema$additionalProperties, spec)
if (ap$type == "object") {
additional_properties <- "object"
if (!is.null(ap$properties)) {
additional_properties_handler <-
swagger_response_handler_object(ap, spec)
}
} else if (ap$type == "array") {
additional_properties <- "array"
additional_properties_handler <- swagger_response_handler_array(ap, spec)
} else if (identical(ap, list(type = "string"))) {
additional_properties <- "string"
} else {
stop("Unsupported additionalProperties") # nocov [stevedore bug]
}
}
els <- names(schema$properties)
els_r <- pascal_to_snake_cached(els)
if (length(els) == 0 && is.null(additional_properties)) {
## This is required for container_stats at least
additional_properties <- "object"
}
properties <- lapply(schema$properties, resolve_schema_ref, spec)
type <- vcapply(properties, swagger_get_type)
is_array_string <- type == "array_string"
if (any(is_array_string)) {
for (i in which(is_array_string)) {
properties[[i]]$type <-
list(type = "array", items = list(type = "string"))
}
type[is_array_string] <- "array"
}
## This is the simplest check now:
stopifnot(all(type %in% c(atomic$names, "object", "array")))
els_atomic <- names(type)[type %in% atomic$names]
els_object <- names(type)[type == "object"]
els_array <- names(type)[type == "array"]
## Quick check here that we found everything ok
found <- c(els_atomic, els_array, els_object)
stopifnot(length(found) == length(els) && setequal(found, els))
object_handlers <- lapply(properties[els_object], function(x)
swagger_response_handler_object(x, spec))
array_handlers <- lapply(properties[els_array], function(x)
swagger_response_handler_array(x, spec))
f_atomic <- function(v, data) {
pick(data, v, atomic$missing[[type[[v]]]])[[1L]]
}
f_object <- function(v, data, output_options) {
x <- pick(data, v, NULL)
x %&&% object_handlers[[v]](x, output_options)
}
f_array <- function(v, data, output_options) {
array_handlers[[v]](pick(data, v, NULL), output_options)
}
function(data, output_options) {
ret <- vector("list", length(type))
names(ret) <- els
ret[els_atomic] <- lapply(els_atomic, f_atomic, data)
ret[els_object] <- lapply(els_object, f_object, data, output_options)
ret[els_array] <- lapply(els_array, f_array, data, output_options)
## TODO: where we have array strings it might be good to
## distinguish between a length 1 array and a string - these have
## differecnes in how they're interpreted. I need to think about
## this on the args side too and probably the solution here should
## reflect the solution there. Probably a "scalar" attribute?
if (!output_options$as_is_names && length(ret) > 0L) {
names(ret) <- els_r
}
if (!is.null(additional_properties)) {
extra <- data[setdiff(names(data), els)]
if (additional_properties == "string" && length(els) == 0L) {
## This deals with the case like the `Options` field in GET
## /volumes; it is defined *only* as `AdditionalProperties:
## "string"`, in which case it's a named character vector;
ret <- character(0)
extra <- vcapply(extra, "[[", 1L)
}
if (length(extra) > 0L) {
if (!is.null(additional_properties_handler)) {
extra <- lapply(extra, additional_properties_handler, output_options)
}
if (!output_options$as_is_names && length(extra) > 0L) {
names(extra) <- pascal_to_snake_cached(names(extra))
}
ret <- c(ret, extra)
}
}
ret
}
}
swagger_response_handler_array <- function(schema, spec) {
items <- resolve_schema_ref(schema$items, spec)
atomic <- atomic_types()
if (is.null(items$type)) {
stop("Missing type in items") # nocov [stevedore bug]
}
if (items$type == "object") {
if (!is.null(items$additionalProperties)) {
swagger_response_handler_array_object_list(items, spec)
} else {
swagger_response_handler_array_object_df(items, spec)
}
} else if (items$type == "array") {
swagger_response_handler_array_array(items, spec)
} else {
swagger_response_handler_array_atomic(atomic$missing[[items$type]],
atomic$empty[[items$type]])
}
}
swagger_response_handler_array_atomic <- function(missing, empty) {
force(missing)
force(empty)
function(x, output_options) {
if (is.null(x)) empty else vapply2(x, identity, missing, USE.NAMES = FALSE)
}
}
swagger_response_handler_array_array <- function(items, spec) {
handler <- swagger_response_handler_array(items, spec)
rm(spec)
function(x, output_options) {
lapply(x, handler, output_options)
}
}
## This one is the nasty case; we handle an object but after
## collection convert it into a data frame. There's some duplication
## here with swagger_response_handler_object but it's not avoidable
## because we need to iterate over each element in the array - we're
## basically transposing it but doing some type conversion at the same
## time!
swagger_response_handler_array_object_df <- function(items, spec) {
atomic <- atomic_types()
items$properties <- lapply(items$properties, resolve_schema_ref, spec)
properties <- lapply(items$properties, resolve_schema_ref, spec)
cols <- names(properties)
cols_r <- pascal_to_snake_cached(cols)
type <- vcapply(properties, "[[", "type")
stopifnot(all(type %in% c(atomic$names, "object", "array")))
cols_atomic <- names(type)[type %in% atomic$names]
cols_object <- names(type)[type == "object"]
cols_array <- names(type)[type == "array"]
object_handlers <- lapply(properties[cols_object], function(x)
swagger_response_handler_object(x, spec))
array_handlers <- lapply(properties[cols_array], function(x)
swagger_response_handler_array(x, spec))
f_atomic <- function(v, data) {
vapply2(data, pick, atomic$type[[type[[v]]]], v,
atomic$missing[[type[[v]]]], USE.NAMES = FALSE)
}
f_array <- function(v, data, output_options) {
x <- lapply(data, pick, v, NULL)
I(lapply(x, array_handlers[[v]], output_options))
}
f_object <- function(v, data, output_options) {
## Ah bollocks - I've totally messed this up here and the
## recursion is not working correctly I think - the data as coming
## in here is missing a layer of listing. This could come from a
## bunch of places unfortunately.
x <- lapply(data, pick, v, NULL)
I(lapply(x, object_handlers[[v]], output_options))
}
function(data, output_options) {
if (!is.null(names(data))) {
stop("Was handed the wrong sort of thing") # nocov [stevedore bug]
}
ret <- vector("list", length(cols))
names(ret) <- cols
ret[cols_atomic] <- lapply(cols_atomic, f_atomic, data)
ret[cols_object] <- lapply(cols_object, f_object, data, output_options)
ret[cols_array] <- lapply(cols_array, f_array, data, output_options)
if (!output_options$as_is_names && length(ret) > 0L) {
names(ret) <- cols_r
}
output_options$data_frame(
as.data.frame(ret, stringsAsFactors = FALSE, check.names = FALSE))
}
}
swagger_response_handler_array_object_list <- function(items, spec) {
properties <- lapply(items$properties, resolve_schema_ref, spec)
if (length(properties) != 0L) {
stop("This is not supported") # nocov
}
items$additionalProperties <-
resolve_schema_ref(items$additionalProperties, spec)
if (identical(items$additionalProperties, list(type = "string"))) {
additional_properties <- "string"
} else {
stop("Unsupported additionalProperties") # nocov [stevedore bug]
}
function(data, output_options) {
if (additional_properties == "string") {
data <- lapply(data, vcapply, identity)
} else {
stop("extra handling needed here") # nocov [stevedore bug]
}
if (!output_options$as_is_names) {
rename <- function(x) {
if (!is.null(names(x))) {
names(x) <- pascal_to_snake_cached(names(x))
}
x
}
data <- lapply(data, rename)
}
data
}
}
swagger_response_handler_binary <- function(...) {
function(data, output_options) {
data
}
}
swagger_response_handler_text <- function(...) {
function(data, output_options) {
raw_to_char(data)
}
}
swagger_response_handler_chunked_string <- function(...) {
function(data, output_options) {
decode_chunked_string(data)
}
}
## Utility for dealing with swagger types
swagger_get_type <- function(x) {
ret <- x$type
if (is.null(ret)) {
if (!is.null(x$enum)) {
ret <- "string"
} else if ("allOf" %in% names(x)) {
stop("Should not happen [stevedore bug]")
} else {
stop("Could not determine type [stevedore bug]")
}
}
if (setequal(ret, c("array", "string"))) {
ret <- "array_string"
}
ret
}
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.