From c8454dc6748af41c28280db9c544a008f7d50b68 Mon Sep 17 00:00:00 2001 From: Jon Harmon Date: Thu, 31 Aug 2023 14:03:05 -0500 Subject: [PATCH] Add servers object. (#23) Closes #4. --- .Rbuildignore | 1 + DESCRIPTION | 3 + NAMESPACE | 5 + R/00-properties.R | 54 +++++++- R/01-info_contact.R | 3 +- R/01-info_license.R | 2 +- R/01-server_variable.R | 67 ++++++++++ R/02_server_variable_list.R | 42 ++++++ R/03-server.R | 58 ++++++++ R/rapid-package.R | 2 + R/validate_in_enum.R | 27 ++++ R/validate_parallel.R | 89 +++++++++++++ man/api_contact.Rd | 3 +- man/server.Rd | 57 ++++++++ man/server_variable.Rd | 50 +++++++ man/server_variable_list.Rd | 25 ++++ principles.md | 10 ++ tests/testthat/_snaps/01-info_contact.md | 4 +- tests/testthat/_snaps/01-info_license.md | 2 +- tests/testthat/_snaps/01-server_variable.md | 126 ++++++++++++++++++ tests/testthat/_snaps/02-info.md | 2 +- .../_snaps/02_server_variable_list.md | 95 +++++++++++++ tests/testthat/_snaps/03-server.md | 39 ++++++ tests/testthat/test-01-info_contact.R | 4 +- tests/testthat/test-01-info_license.R | 2 +- tests/testthat/test-01-server_variable.R | 95 +++++++++++++ tests/testthat/test-02-info.R | 2 +- tests/testthat/test-02_server_variable_list.R | 35 +++++ tests/testthat/test-03-server.R | 37 +++++ 29 files changed, 925 insertions(+), 16 deletions(-) create mode 100644 R/01-server_variable.R create mode 100644 R/02_server_variable_list.R create mode 100644 R/03-server.R create mode 100644 R/validate_in_enum.R create mode 100644 R/validate_parallel.R create mode 100644 man/server.Rd create mode 100644 man/server_variable.Rd create mode 100644 man/server_variable_list.Rd create mode 100644 principles.md create mode 100644 tests/testthat/_snaps/01-server_variable.md create mode 100644 tests/testthat/_snaps/02_server_variable_list.md create mode 100644 tests/testthat/_snaps/03-server.md create mode 100644 tests/testthat/test-01-server_variable.R create mode 100644 tests/testthat/test-02_server_variable_list.R create mode 100644 tests/testthat/test-03-server.R diff --git a/.Rbuildignore b/.Rbuildignore index 34a078c..5e9126c 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -8,3 +8,4 @@ ^_pkgdown\.yml$ ^docs$ ^pkgdown$ +^principles\.md$ diff --git a/DESCRIPTION b/DESCRIPTION index 2755fc0..3d337aa 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -16,6 +16,9 @@ URL: https://jonthegeek.github.io/rapid/, https://github.com/jonthegeek/rapid BugReports: https://github.com/jonthegeek/rapid/issues Imports: + cli, + glue, + purrr, rlang (>= 1.1.0), S7, stbl diff --git a/NAMESPACE b/NAMESPACE index a55a693..f559807 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,7 +3,12 @@ export(api_contact) export(api_info) export(api_license) +export(server) +export(server_variable) +export(server_variable_list) if (getRversion() < "4.3.0") importFrom("S7", "@") +importFrom(glue,glue) +importFrom(rlang,"%||%") importFrom(rlang,check_dots_empty) importFrom(rlang,check_dots_used) importFrom(stbl,stabilize_chr_scalar) diff --git a/R/00-properties.R b/R/00-properties.R index ba46d9b..8b0165c 100644 --- a/R/00-properties.R +++ b/R/00-properties.R @@ -19,9 +19,57 @@ character_scalar_property <- function(x_arg, regex = NULL) { ) } +character_property <- function(x_arg, regex = NULL) { + S7::new_property( + class = S7::class_character, + setter = function(self, value) { + # TODO: Watch S7 dev to see if this can be less hacky. + call <- rlang::caller_env(3) + value <- stbl::stabilize_chr( + value, + allow_null = FALSE, + regex = regex, + x_arg = x_arg, + call = call + ) + S7::prop(self, x_arg, check = FALSE) <- value + self + } + ) +} + +.url_regex <- "http[s]?://(?:[a-zA-Z]|[0-9]|[$-_@.&+]|[!*\\(\\),{}]|(?:%[0-9a-fA-F][0-9a-fA-F]))+" + url_scalar_property <- function(x_arg) { - character_scalar_property( - x_arg, - regex = "http[s]?://(?:[a-zA-Z]|[0-9]|[$-_@.&+]|[!*\\(\\),]|(?:%[0-9a-fA-F][0-9a-fA-F]))+" + character_scalar_property(x_arg, regex = .url_regex) +} + +url_property <- function(x_arg) { + character_property(x_arg, regex = .url_regex) +} + +enum_property <- function(x_arg) { + S7::new_property( + class = S7::class_list, + setter = function(self, value) { + call <- rlang::caller_env(3) + if (!is.null(value) && !is.list(value)) { + value <- list(value) + } + value <- purrr::map( + value, + \(enumerations) { + enumerations <- stbl::stabilize_chr( + enumerations, + allow_na = FALSE, + x_arg = x_arg, + call = call + ) + enumerations + } + ) + S7::prop(self, x_arg, check = FALSE) <- value + self + } ) } diff --git a/R/01-info_contact.R b/R/01-info_contact.R index 54ed5b0..9b6904b 100644 --- a/R/01-info_contact.R +++ b/R/01-info_contact.R @@ -8,8 +8,7 @@ #' @param email The email address of the contact person/organization. This #' *must* be in the form of an email address. #' -#' @return An `api_contact` S7 object, with fields `name`, `email`, and -#' `url`. +#' @return An `api_contact` S7 object, with fields `name`, `email`, and `url`. #' @export #' #' @examples diff --git a/R/01-info_license.R b/R/01-info_license.R index ce26a02..fd22ff1 100644 --- a/R/01-info_license.R +++ b/R/01-info_license.R @@ -38,7 +38,7 @@ api_license <- S7::new_class( ..., identifier = character(), url = character()) { - rlang::check_dots_empty() + check_dots_empty() S7::new_object(NULL, name = name, identifier = identifier, url = url) }, validator = function(self) { diff --git a/R/01-server_variable.R b/R/01-server_variable.R new file mode 100644 index 0000000..a933124 --- /dev/null +++ b/R/01-server_variable.R @@ -0,0 +1,67 @@ +#' A server variable for server URL template substitution +#' +#' Server variable properties used for substitution in the server’s URL +#' template. +#' +#' @inheritParams rlang::args_dots_empty +#' @param name Character vector (required). The names of the variables. +#' @param default Character vector (required). The default value to use for +#' substitution of each variable, which *shall* be sent if an alternate value +#' is not supplied. Note this behavior is different than the Schema Object’s +#' treatment of default values, because in those cases parameter values are +#' optional. If the `enum` is defined, the value *must* exist in the enum’s +#' values. +#' @param enum List of (potentially empty) character vectors (optional). An +#' enumeration of string values to be used if the substitution options are +#' from a limited set. +#' @param description Character vector (optional). An optional description for +#' each server variable. [CommonMark syntax](https://spec.commonmark.org/) +#' *may* be used for rich text representation. +#' +#' @return A `server_variable` S7 object, with fields `name`, `default`, `enum`, +#' and `description`. +#' @export +#' +#' @examples +#' server_variable( +#' "username", +#' "demo", +#' enum = c("demo", "other"), +#' description = "The active user's folder." +#' ) +server_variable <- S7::new_class( + "server_variable", + package = "rapid", + properties = list( + name = character_property("name"), + default = character_property("default"), + enum = enum_property("enum"), + description = character_property("description") + ), + constructor = function(name = character(), + default = character(), + ..., + enum = NULL, + description = character()) { + check_dots_empty() + S7::new_object( + NULL, + name = name, + default = default, + enum = enum, + description = description + ) + }, + validator = function(self) { + validate_parallel( + self, + key = "name", + required = "default", + optional = c("enum", "description") + ) %||% validate_in_enum( + self, + value_name = "default", + enum_name = "enum" + ) + } +) diff --git a/R/02_server_variable_list.R b/R/02_server_variable_list.R new file mode 100644 index 0000000..8c220dd --- /dev/null +++ b/R/02_server_variable_list.R @@ -0,0 +1,42 @@ +#' A collection of server variables for multiple servers +#' +#' A list of server variable objects, each of which is constructed with +#' [server_variable()]. +#' +#' @param ... One or more [server_variable()] objects, or a list of +#' [server_variable()] objects. +#' +#' @return A `server_variable_list` S7 object, which is a validated list of +#' [server_variable()] objects. +#' @export +#' +#' @examples +#' server_variable_list( +#' list(server_variable(), server_variable()) +#' ) +server_variable_list <- S7::new_class( + "server_variable_list", + package = "rapid", + parent = S7::class_list, + constructor = function(...) { + if (...length() == 1 && is.list(..1)) { + return(S7::new_object(..1)) + } + S7::new_object(list(...)) + }, + validator = function(self) { + bad_server_vars <- !purrr::map_lgl( + S7::S7_data(self), + ~ S7::S7_inherits(.x, server_variable) + ) + if (any(bad_server_vars)) { + bad_locations <- which(bad_server_vars) + c( + cli::format_inline( + "All values must be {.cls server_variable} objects." + ), + cli::format_inline("Bad values at {bad_locations}.") + ) + } + } +) diff --git a/R/03-server.R b/R/03-server.R new file mode 100644 index 0000000..0c57af0 --- /dev/null +++ b/R/03-server.R @@ -0,0 +1,58 @@ +#' A collection of server variables for multiple servers +#' +#' Connectivity information for an API. +#' +#' @param url A list of [server_variable()] objects. +#' @param description A list of [server_variable()] objects. +#' @param variables [server_variable_list()] object. +#' +#' @return A `server` S7 object, with properties `url`, `description`, and +#' `variables`. +#' @export +#' +#' @examples +#' server( +#' url = c( +#' "https://development.gigantic-server.com/v1", +#' "https://staging.gigantic-server.com/v1", +#' "https://api.gigantic-server.com/v1" +#' ), +#' description = c( +#' "Development server", +#' "Staging server", +#' "Production server" +#' ) +#' ) +#' server( +#' url = "https://{username}.gigantic-server.com:{port}/{basePath}", +#' description = "The production API server", +#' variables = server_variable_list(server_variable( +#' name = c("username", "port", "basePath"), +#' default = c("demo", "8443", "v2"), +#' description = c( +#' "The active user's folder.", +#' NA, NA +#' ), +#' enum = list( +#' NULL, +#' c("8443", "443"), +#' NULL +#' ) +#' )) +#' ) +server <- S7::new_class( + "server", + package = "rapid", + properties = list( + url = url_property("url"), + description = character_property("description"), + variables = server_variable_list + ), + validator = function(self) { + validate_parallel( + self, + "url", + optional = c("description", "variables") + ) + } +) diff --git a/R/rapid-package.R b/R/rapid-package.R index a5333a8..d6c49d1 100644 --- a/R/rapid-package.R +++ b/R/rapid-package.R @@ -2,6 +2,8 @@ "_PACKAGE" ## usethis namespace: start +#' @importFrom glue glue +#' @importFrom rlang %||% #' @importFrom rlang check_dots_empty #' @importFrom rlang check_dots_used #' @importFrom stbl stabilize_chr_scalar diff --git a/R/validate_in_enum.R b/R/validate_in_enum.R new file mode 100644 index 0000000..dad6552 --- /dev/null +++ b/R/validate_in_enum.R @@ -0,0 +1,27 @@ +validate_in_enum <- function(obj, + value_name, + enum_name) { + values <- S7::prop(obj, value_name) + enums <- S7::prop(obj, enum_name) + + if (length(enums)) { + missing_msgs <- purrr::map2( + values, enums, + \(value, enum) { + if (length(enum) && !(value %in% enum)) { + cli::format_inline("{.val {value}} is not in {.val {enum}}.") + } + } + ) |> + unlist() + + if (is.null(missing_msgs)) { + return(NULL) + } + + c( + cli::format_inline("{.arg {value_name}} must be in {.arg {enum_name}}."), + missing_msgs + ) + } +} diff --git a/R/validate_parallel.R b/R/validate_parallel.R new file mode 100644 index 0000000..f61960e --- /dev/null +++ b/R/validate_parallel.R @@ -0,0 +1,89 @@ +validate_parallel <- function(obj, + key, + required = NULL, + optional = NULL) { + key_len <- .prop_lengths(obj, key) + required_lens <- .prop_lengths(obj, required) + + if (!all(required_lens == key_len)) { + return(.msg_same(key, key_len, required, required_lens)) + } + + optional_lens <- .prop_lengths(obj, optional) + + if (key_len) { + return( + .msg_same_or_empty(key, key_len, optional, optional_lens) + ) + } + + return( + .msg_empty(key, c(required, optional), c(required_lens, optional_lens)) + ) +} + +.prop_lengths <- function(obj, prop_names) { + purrr::map_int( + prop_names, + \(prop_name) { + length(S7::prop(obj, prop_name)) + } + ) +} + +.msg_same <- function(key_name, key_length, prop_names, prop_lengths) { + bad_lengths <- prop_lengths != key_length + not_same <- prop_names[bad_lengths] + return( + c( + cli::format_inline( + "{.arg {not_same}} must have the same length as {.arg {key_name}}" + ), + .msg_sizes(key_name, key_length), + .msg_sizes(not_same, prop_lengths[bad_lengths]) + ) + ) +} + +.msg_same_or_empty <- function(key_name, key_length, prop_names, prop_lengths) { + bad_lengths <- prop_lengths & prop_lengths != key_length + if (any(bad_lengths)) { + bad_size <- prop_names[bad_lengths] + return( + c( + cli::format_inline( + "{.arg {bad_size}} must be empty or have the same length as {.arg {key_name}}" + ), + .msg_sizes(key_name, key_length), + .msg_sizes(bad_size, prop_lengths[bad_lengths]) + ) + ) + } +} + +.msg_empty <- function(key_name, prop_names, prop_lengths) { + bad_lengths <- prop_lengths > 0 + if (any(bad_lengths)) { + not_empty <- prop_names[bad_lengths] + return( + c( + cli::format_inline( + "When {.arg {key_name}} is not defined, {.arg {not_empty}} must be empty." + ), + .msg_sizes(not_empty, prop_lengths[bad_lengths]) + ) + ) + } +} + +.msg_sizes <- function(prop_names, prop_lengths) { + purrr::map2_chr( + prop_names, + prop_lengths, + \(prop_name, prop_length) { + cli::format_inline( + "{.arg {prop_name}} has {cli::no(prop_length)} value{?s}." + ) + } + ) +} diff --git a/man/api_contact.Rd b/man/api_contact.Rd index 6b35976..bcd282d 100644 --- a/man/api_contact.Rd +++ b/man/api_contact.Rd @@ -16,8 +16,7 @@ api_contact(name = class_missing, email = class_missing, url = class_missing) form of a URL.} } \value{ -An \code{api_contact} S7 object, with fields \code{name}, \code{email}, and -\code{url}. +An \code{api_contact} S7 object, with fields \code{name}, \code{email}, and \code{url}. } \description{ Validate the contact information for an API. diff --git a/man/server.Rd b/man/server.Rd new file mode 100644 index 0000000..279a1c1 --- /dev/null +++ b/man/server.Rd @@ -0,0 +1,57 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/03-server.R +\name{server} +\alias{server} +\title{A collection of server variables for multiple servers} +\usage{ +server( + url = class_missing, + description = class_missing, + variables = class_missing +) +} +\arguments{ +\item{url}{A list of \code{\link[=server_variable]{server_variable()}} objects.} + +\item{description}{A list of \code{\link[=server_variable]{server_variable()}} objects.} + +\item{variables}{\code{\link[=server_variable_list]{server_variable_list()}} object.} +} +\value{ +A \code{server} S7 object, with properties \code{url}, \code{description}, and +\code{variables}. +} +\description{ +Connectivity information for an API. +} +\examples{ +server( + url = c( + "https://development.gigantic-server.com/v1", + "https://staging.gigantic-server.com/v1", + "https://api.gigantic-server.com/v1" + ), + description = c( + "Development server", + "Staging server", + "Production server" + ) +) +server( + url = "https://{username}.gigantic-server.com:{port}/{basePath}", + description = "The production API server", + variables = server_variable_list(server_variable( + name = c("username", "port", "basePath"), + default = c("demo", "8443", "v2"), + description = c( + "The active user's folder.", + NA, NA + ), + enum = list( + NULL, + c("8443", "443"), + NULL + ) + )) +) +} diff --git a/man/server_variable.Rd b/man/server_variable.Rd new file mode 100644 index 0000000..2c4f4ee --- /dev/null +++ b/man/server_variable.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/01-server_variable.R +\name{server_variable} +\alias{server_variable} +\title{A server variable for server URL template substitution} +\usage{ +server_variable( + name = character(), + default = character(), + ..., + enum = NULL, + description = character() +) +} +\arguments{ +\item{name}{Character vector (required). The names of the variables.} + +\item{default}{Character vector (required). The default value to use for +substitution of each variable, which \emph{shall} be sent if an alternate value +is not supplied. Note this behavior is different than the Schema Object’s +treatment of default values, because in those cases parameter values are +optional. If the \code{enum} is defined, the value \emph{must} exist in the enum’s +values.} + +\item{...}{These dots are for future extensions and must be empty.} + +\item{enum}{List of (potentially empty) character vectors (optional). An +enumeration of string values to be used if the substitution options are +from a limited set.} + +\item{description}{Character vector (optional). An optional description for +each server variable. \href{https://spec.commonmark.org/}{CommonMark syntax} +\emph{may} be used for rich text representation.} +} +\value{ +A \code{server_variable} S7 object, with fields \code{name}, \code{default}, \code{enum}, +and \code{description}. +} +\description{ +Server variable properties used for substitution in the server’s URL +template. +} +\examples{ +server_variable( + "username", + "demo", + enum = c("demo", "other"), + description = "The active user's folder." +) +} diff --git a/man/server_variable_list.Rd b/man/server_variable_list.Rd new file mode 100644 index 0000000..c536353 --- /dev/null +++ b/man/server_variable_list.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/02_server_variable_list.R +\name{server_variable_list} +\alias{server_variable_list} +\title{A collection of server variables for multiple servers} +\usage{ +server_variable_list(...) +} +\arguments{ +\item{...}{One or more \code{\link[=server_variable]{server_variable()}} objects, or a list of +\code{\link[=server_variable]{server_variable()}} objects.} +} +\value{ +A \code{server_variable_list} S7 object, which is a validated list of +\code{\link[=server_variable]{server_variable()}} objects. +} +\description{ +A list of server variable objects, each of which is constructed with +\code{\link[=server_variable]{server_variable()}}. +} +\examples{ +server_variable_list( + list(server_variable(), server_variable()) +) +} diff --git a/principles.md b/principles.md new file mode 100644 index 0000000..be8511c --- /dev/null +++ b/principles.md @@ -0,0 +1,10 @@ +# rapid design principles + +*This is an experiment in making key package design principles explicit, versus only implicit in the code. The goal is to make maintenance easier, when spread out over time and across people. This idea was copied from [usethis](https://github.com/r-lib/usethis/blob/main/principles.md).* + +## Class names + +I've gone back and forth between "api_{class}" and "{class}" for the class names. +The rule that seems to be emerging is to add "api_" when necessary, but try not to do so. + +This rule still might change. diff --git a/tests/testthat/_snaps/01-info_contact.md b/tests/testthat/_snaps/01-info_contact.md index 825ece4..2d3981e 100644 --- a/tests/testthat/_snaps/01-info_contact.md +++ b/tests/testthat/_snaps/01-info_contact.md @@ -69,7 +69,7 @@ x Some values do not match. * Locations: 1 -# api_contact() returns an api_contact when everything is ok +# api_contact() returns a contact when everything is ok Code test_result <- api_contact(name = "A", url = "https://example.com", email = "real.email@address.place") @@ -80,7 +80,7 @@ @ email: chr "real.email@address.place" @ url : chr "https://example.com" -# api_contact() without args returns an empty api_contact. +# api_contact() without args returns an empty api_contact Code test_result <- api_contact() diff --git a/tests/testthat/_snaps/01-info_license.md b/tests/testthat/_snaps/01-info_license.md index 9e43e13..a2aff61 100644 --- a/tests/testthat/_snaps/01-info_license.md +++ b/tests/testthat/_snaps/01-info_license.md @@ -79,7 +79,7 @@ * ..1 = "https://example.com" i Did you forget to name an argument? -# api_license() returns an api_license when everything is ok +# api_license() returns a license when everything is ok Code test_result <- api_license(name = "A", url = "https://example.com") diff --git a/tests/testthat/_snaps/01-server_variable.md b/tests/testthat/_snaps/01-server_variable.md new file mode 100644 index 0000000..cbe004f --- /dev/null +++ b/tests/testthat/_snaps/01-server_variable.md @@ -0,0 +1,126 @@ +# server_variable() requires names for optional args + + Code + server_variable("a", "b", "c") + Condition + Error in `server_variable()`: + ! `...` must be empty. + x Problematic argument: + * ..1 = "c" + i Did you forget to name an argument? + +# server_variable() requires that default matches name + + Code + server_variable("a") + Condition + Error: + ! object is invalid: + - `default` must have the same length as `name` + - `name` has 1 value. + - `default` has no values. + +--- + + Code + server_variable("a", letters) + Condition + Error: + ! object is invalid: + - `default` must have the same length as `name` + - `name` has 1 value. + - `default` has 26 values. + +--- + + Code + server_variable(letters, "a") + Condition + Error: + ! object is invalid: + - `default` must have the same length as `name` + - `name` has 26 values. + - `default` has 1 value. + +--- + + Code + server_variable(character(), "a") + Condition + Error: + ! object is invalid: + - `default` must have the same length as `name` + - `name` has no values. + - `default` has 1 value. + +# server_variable() works with equal-length name/default + + Code + test_result <- server_variable("a", "b") + test_result + Output + + @ name : chr "a" + @ default : chr "b" + @ enum : list() + @ description: chr(0) + +# server_variable() requires that optional args are empty or match + + Code + server_variable("a", "b", enum = list("a", "b")) + Condition + Error: + ! object is invalid: + - `enum` must be empty or have the same length as `name` + - `name` has 1 value. + - `enum` has 2 values. + +--- + + Code + server_variable("a", "b", description = c("a", "b")) + Condition + Error: + ! object is invalid: + - `description` must be empty or have the same length as `name` + - `name` has 1 value. + - `description` has 2 values. + +# server_variable() requires that the default is in enum when given + + Code + server_variable(name = "a", default = "b", enum = "a") + Condition + Error: + ! object is invalid: + - `default` must be in `enum`. + - "b" is not in "a". + +--- + + Code + server_variable(name = c("a", "b"), default = c("b", "a"), enum = list("a", "a")) + Condition + Error: + ! object is invalid: + - `default` must be in `enum`. + - "b" is not in "a". + +# server_variable() works for a full object + + Code + test_result <- server_variable(name = c("username", "port", "basePath"), + default = c("demo", "8443", "v2"), description = c("The active user's folder.", + NA, NA), enum = list(NULL, c("8443", "443"), NULL)) + test_result + Output + + @ name : chr [1:3] "username" "port" "basePath" + @ default : chr [1:3] "demo" "8443" "v2" + @ enum :List of 3 + .. $ : NULL + .. $ : chr [1:2] "8443" "443" + .. $ : NULL + @ description: chr [1:3] "The active user's folder." NA NA + diff --git a/tests/testthat/_snaps/02-info.md b/tests/testthat/_snaps/02-info.md index 9ab2021..1c42641 100644 --- a/tests/testthat/_snaps/02-info.md +++ b/tests/testthat/_snaps/02-info.md @@ -25,7 +25,7 @@ x Some values do not match. * Locations: 1 -# api_info() returns an empty api_info. +# api_info() returns an empty api_info Code test_result <- api_info() diff --git a/tests/testthat/_snaps/02_server_variable_list.md b/tests/testthat/_snaps/02_server_variable_list.md new file mode 100644 index 0000000..3941513 --- /dev/null +++ b/tests/testthat/_snaps/02_server_variable_list.md @@ -0,0 +1,95 @@ +# server_variable_list() errors informatively for bad contents + + Code + server_variable_list(letters) + Condition + Error: + ! object is invalid: + - All values must be objects. + - Bad values at 1. + +--- + + Code + server_variable_list(list(letters, letters)) + Condition + Error: + ! object is invalid: + - All values must be objects. + - Bad values at 1 and 2. + +--- + + Code + server_variable_list(server_variable(), letters, server_variable(), letters) + Condition + Error: + ! object is invalid: + - All values must be objects. + - Bad values at 2 and 4. + +# server_variable_list() returns an empty server_variable_list + + Code + server_variable_list() + Output + list() + +# server_variable_list() accepts bare server_variables + + Code + server_variable_list(server_variable()) + Output + List of 1 + $ : + ..@ name : chr(0) + ..@ default : chr(0) + ..@ enum : list() + ..@ description: chr(0) + +--- + + Code + server_variable_list(server_variable(), server_variable()) + Output + List of 2 + $ : + ..@ name : chr(0) + ..@ default : chr(0) + ..@ enum : list() + ..@ description: chr(0) + $ : + ..@ name : chr(0) + ..@ default : chr(0) + ..@ enum : list() + ..@ description: chr(0) + +# server_variable_list() accepts lists of server_variables + + Code + server_variable_list(list(server_variable())) + Output + List of 1 + $ : + ..@ name : chr(0) + ..@ default : chr(0) + ..@ enum : list() + ..@ description: chr(0) + +--- + + Code + server_variable_list(list(server_variable(), server_variable())) + Output + List of 2 + $ : + ..@ name : chr(0) + ..@ default : chr(0) + ..@ enum : list() + ..@ description: chr(0) + $ : + ..@ name : chr(0) + ..@ default : chr(0) + ..@ enum : list() + ..@ description: chr(0) + diff --git a/tests/testthat/_snaps/03-server.md b/tests/testthat/_snaps/03-server.md new file mode 100644 index 0000000..9c9925b --- /dev/null +++ b/tests/testthat/_snaps/03-server.md @@ -0,0 +1,39 @@ +# server() requires URLs for url + + Code + server(url = mean) + Condition + Error in `server()`: + ! Can't coerce `url` to . + +--- + + Code + server(url = c("A", "B")) + Condition + Error in `server()`: + ! `url` must match the provided regex pattern. + x Some values do not match. + * Locations: 1 and 2 + +--- + + Code + server(url = "not a real url") + Condition + Error in `server()`: + ! `url` must match the provided regex pattern. + x Some values do not match. + * Locations: 1 + +# server() returns an empty server + + Code + test_result <- server() + test_result + Output + + @ url : chr(0) + @ description: chr(0) + @ variables : list() + diff --git a/tests/testthat/test-01-info_contact.R b/tests/testthat/test-01-info_contact.R index 029ac33..3300d83 100644 --- a/tests/testthat/test-01-info_contact.R +++ b/tests/testthat/test-01-info_contact.R @@ -51,7 +51,7 @@ test_that("api_contact() errors informatively for bad email", { ) }) -test_that("api_contact() returns an api_contact when everything is ok", { +test_that("api_contact() returns a contact when everything is ok", { expect_snapshot({ test_result <- api_contact( name = "A", @@ -71,7 +71,7 @@ test_that("api_contact() returns an api_contact when everything is ok", { ) }) -test_that("api_contact() without args returns an empty api_contact.", { +test_that("api_contact() without args returns an empty api_contact", { expect_snapshot({ test_result <- api_contact() test_result diff --git a/tests/testthat/test-01-info_license.R b/tests/testthat/test-01-info_license.R index f36b005..249355d 100644 --- a/tests/testthat/test-01-info_license.R +++ b/tests/testthat/test-01-info_license.R @@ -57,7 +57,7 @@ test_that("api_license() doesn't match identifier by position", { ) }) -test_that("api_license() returns an api_license when everything is ok", { +test_that("api_license() returns a license when everything is ok", { expect_snapshot({ test_result <- api_license( name = "A", diff --git a/tests/testthat/test-01-server_variable.R b/tests/testthat/test-01-server_variable.R new file mode 100644 index 0000000..1a51d4a --- /dev/null +++ b/tests/testthat/test-01-server_variable.R @@ -0,0 +1,95 @@ +test_that("server_variable() requires names for optional args", { + expect_snapshot( + server_variable("a", "b", "c"), + error = TRUE + ) +}) + +test_that("server_variable() requires that default matches name", { + expect_snapshot( + server_variable("a"), + error = TRUE + ) + expect_snapshot( + server_variable("a", letters), + error = TRUE + ) + expect_snapshot( + server_variable(letters, "a"), + error = TRUE + ) + expect_snapshot( + server_variable(character(), "a"), + error = TRUE + ) +}) + +test_that("server_variable() works with equal-length name/default", { + expect_snapshot({ + test_result <- server_variable("a", "b") + test_result + }) + expect_s3_class( + test_result, + class = c("rapid::server_variable", "S7_object"), + exact = TRUE + ) + expect_identical( + S7::prop_names(test_result), + c("name", "default", "enum", "description") + ) +}) + +test_that("server_variable() requires that optional args are empty or match", { + expect_snapshot( + server_variable("a", "b", enum = list("a", "b")), + error = TRUE + ) + expect_snapshot( + server_variable("a", "b", description = c("a", "b")), + error = TRUE + ) +}) + +test_that("server_variable() requires that the default is in enum when given", { + expect_snapshot( + server_variable(name = "a", default = "b", enum = "a"), + error = TRUE + ) + expect_snapshot( + server_variable( + name = c("a", "b"), + default = c("b", "a"), + enum = list("a", "a") + ), + error = TRUE + ) +}) + +test_that("server_variable() works for a full object", { + expect_snapshot({ + test_result <- server_variable( + name = c("username", "port", "basePath"), + default = c("demo", "8443", "v2"), + description = c( + "The active user's folder.", + NA, NA + ), + enum = list( + NULL, + c("8443", "443"), + NULL + ) + ) + test_result + }) + expect_s3_class( + test_result, + class = c("rapid::server_variable", "S7_object"), + exact = TRUE + ) + expect_identical( + S7::prop_names(test_result), + c("name", "default", "enum", "description") + ) +}) diff --git a/tests/testthat/test-02-info.R b/tests/testthat/test-02-info.R index 234f0f0..aa18134 100644 --- a/tests/testthat/test-02-info.R +++ b/tests/testthat/test-02-info.R @@ -21,7 +21,7 @@ test_that("api_info() requires URLs for TOS", { ) }) -test_that("api_info() returns an empty api_info.", { +test_that("api_info() returns an empty api_info", { expect_snapshot({ test_result <- api_info() test_result diff --git a/tests/testthat/test-02_server_variable_list.R b/tests/testthat/test-02_server_variable_list.R new file mode 100644 index 0000000..d8344c8 --- /dev/null +++ b/tests/testthat/test-02_server_variable_list.R @@ -0,0 +1,35 @@ +test_that("server_variable_list() errors informatively for bad contents", { + expect_snapshot( + server_variable_list(letters), + error = TRUE + ) + expect_snapshot( + server_variable_list(list(letters, letters)), + error = TRUE + ) + expect_snapshot( + server_variable_list( + server_variable(), + letters, + server_variable(), + letters + ), + error = TRUE + ) +}) + +test_that("server_variable_list() returns an empty server_variable_list", { + expect_snapshot(server_variable_list()) +}) + +test_that("server_variable_list() accepts bare server_variables", { + expect_snapshot(server_variable_list(server_variable())) + expect_snapshot(server_variable_list(server_variable(), server_variable())) +}) + +test_that("server_variable_list() accepts lists of server_variables", { + expect_snapshot(server_variable_list(list(server_variable()))) + expect_snapshot( + server_variable_list(list(server_variable(), server_variable())) + ) +}) diff --git a/tests/testthat/test-03-server.R b/tests/testthat/test-03-server.R new file mode 100644 index 0000000..4f70800 --- /dev/null +++ b/tests/testthat/test-03-server.R @@ -0,0 +1,37 @@ +test_that("server() requires URLs for url", { + expect_snapshot( + server(url = mean), + error = TRUE, + cnd_class = TRUE + ) + expect_snapshot( + server(url = c("A", "B")), + error = TRUE, + cnd_class = TRUE + ) + expect_snapshot( + server(url = "not a real url"), + error = TRUE, + cnd_class = TRUE + ) +}) + +test_that("server() returns an empty server", { + expect_snapshot({ + test_result <- server() + test_result + }) + expect_s3_class( + test_result, + class = c("rapid::server", "S7_object"), + exact = TRUE + ) + expect_identical( + S7::prop_names(test_result), + c( + "url", + "description", + "variables" + ) + ) +})