Add servers object. (#23)

Closes #4.

.Rbuildignore

@@ -8,3 +8,4 @@
 ^_pkgdown\.yml$
 ^docs$
 ^pkgdown$
+^principles\.md$

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

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)

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
+    }
   )
 }

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

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) {

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"
+    )
+  }
+)

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}.")
+      )
+    }
+  }
+)

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")
+    )
+  }
+)

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

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
+    )
+  }
+}