Add origin info. (#67)

* Add origin info.

* Add origin to pkgdown.

DESCRIPTION

@@ -50,6 +50,7 @@ Collate:
     'components.R'
     'info-contact.R'
     'info-license.R'
+    'info-origin.R'
     'info.R'
     'rapid-package.R'
     'security_requirements.R'

NAMESPACE

@@ -10,6 +10,7 @@ export(as_oauth2_authorization_code_flow)
 export(as_oauth2_implicit_flow)
 export(as_oauth2_security_scheme)
 export(as_oauth2_token_flow)
+export(as_origin)
 export(as_rapid)
 export(as_scopes)
 export(as_security_requirements)
@@ -19,6 +20,7 @@ export(as_security_scheme_details)
 export(as_server_variables)
 export(as_servers)
 export(as_string_replacements)
+export(class_origin)
 export(component_collection)
 export(contact)
 export(info)

R/as.R

@@ -19,14 +19,20 @@
     return(NULL)
   }
 
-  valid_names <- c(S7::prop_names(target_S7_class()), names(extra_names))
+  valid_names <- snakecase::to_snake_case(
+    c(S7::prop_names(target_S7_class()), names(extra_names))
+  )
 
   if (rlang::is_named2(x)) {
     force(x_arg)
     x <- rlang::set_names(x, snakecase::to_snake_case)
     ignored_names <- names(x)[!names(x) %in% valid_names]
     x <- as.list(x)[names(x) %in% valid_names]
     if (length(extra_names)) {
+      extra_names <- rlang::set_names(
+        snakecase::to_snake_case(extra_names),
+        snakecase::to_snake_case(names(extra_names))
+      )
       to_rename <- names(x) %in% names(extra_names)
       names(x)[to_rename] <- extra_names[names(x)[to_rename]]
     }

R/info-origin.R

@@ -0,0 +1,122 @@
+#' @include properties.R
+NULL
+
+#' Source information for the API description
+#'
+#' A `class_origin` object provides information about the primary source
+#' document(s) used to build an API.
+#'
+#' @inheritParams rlang::args_dots_empty
+#' @param url Character (required). The URL(s) where the document(s) can be
+#'   found.
+#' @param format Character scalar (optional). The format of the document.
+#'   Presently this will likely always be "openapi".
+#' @param version Character scalar (optional). The specification version
+#'   (relative to the `format`) used in defining the document. Not to be
+#'   confused with the version of the API description itself. Most often this
+#'   will be "3.0" (as in "OpenAPI Specification version 3.0"), "3.1", or a
+#'   patch version of those.
+#'
+#' @return A `class_origin` S7 object describing where to find the API
+#'   description, with fields `url`, `format`, and `version`.
+#' @export
+#'
+#' @seealso [as_origin()] for coercing objects to `class_origin`.
+#'
+#' @examples
+#' class_origin(
+#'   "https://api.open.fec.gov/swagger/",
+#'   format = "openapi",
+#'   version = "3.0"
+#' )
+class_origin <- S7::new_class(
+  "class_origin",
+  package = "rapid",
+  properties = list(
+    url = character_scalar_property("url"),
+    format = character_scalar_property("format"),
+    version = character_scalar_property("version")
+  ),
+  constructor = function(url = character(),
+                         ...,
+                         format = character(),
+                         version = character()) {
+    check_dots_empty()
+    if (is.list(url) && length(url) == 1) {
+      url <- unname(unlist(url))
+    }
+
+    S7::new_object(
+      S7::S7_object(),
+      url = url %|0|% character(),
+      format = format %|0|% character(),
+      version = version %|0|% character()
+    )
+  },
+  validator = function(self) {
+    validate_parallel(self, "url", optional = c("format", "version"))
+  }
+)
+
+S7::method(length, class_origin) <- function(x) {
+  length(x@url)
+}
+
+#' Coerce lists and character vectors to class_origin
+#'
+#' `as_origin()` turns an existing object into a `class_origin`. This is in
+#' contrast with [class_origin()], which builds a `class_origin` from individual
+#' properties.
+#'
+#' @inheritParams rlang::args_dots_empty
+#' @inheritParams rlang::args_error_context
+#' @param x The object to coerce. Must be empty or have names "url", "format",
+#'   and/or "version", or names that can be coerced to those names via
+#'   [snakecase::to_snake_case()]. Extra names are ignored. This object should
+#'   describe a single origin for this API description.
+#'
+#' @return A `class_origin` as returned by [class_origin()].
+#' @export
+#'
+#' @examples
+#' as_origin()
+#' as_origin(
+#'   list(
+#'     list(
+#'       format = "openapi",
+#'       url = "https://api.open.fec.gov/swagger/",
+#'       version = "3.0"
+#'     )
+#'   )
+#' )
+as_origin <- S7::new_generic("as_origin", dispatch_args = "x")
+
+S7::method(as_origin, class_origin) <- function(x) {
+  x
+}
+
+S7::method(as_origin, class_list | class_character) <- function(x) {
+  # Case 1: Passed in as a simple character vector, or that wrapped in a list.
+  if (length(x) == 1 && lengths(x) == 1 && is.character(unlist(x))) {
+    x <- list(url = unname(unlist(x)))
+  }
+  # Case 2: apis.guru provides a list of lists, but we currently only support
+  # the case where that list has 1 entry.
+  if (length(x) == 1 && lengths(x) > 1) {
+    x <- x[[1]]
+  }
+
+  .as_class(x, class_origin)
+}
+
+S7::method(as_origin, class_missing | NULL) <- function(x) {
+  class_origin()
+}
+
+S7::method(as_origin, class_any) <- function(x,
+                                              ...,
+                                              arg = rlang::caller_arg(x)) {
+  cli::cli_abort(
+    "Can't coerce {.arg {arg}} {.cls {class(x)}} to {.cls class_origin}."
+  )
+}

R/info.R

@@ -1,5 +1,6 @@
 #' @include info-contact.R
 #' @include info-license.R
+#' @include info-origin.R
 #' @include properties.R
 NULL
 
@@ -25,6 +26,10 @@ NULL
 #' @param summary Character scalar (optional). A short summary of the API.
 #' @param terms_of_service Character scalar (optional). A URL to the Terms of
 #'   Service for the API.
+#' @param origin The url and related information about the document used to
+#'   build the API description. This is used to resolve relative paths in the
+#'   API description. Note: This is not part of the OpenAPI Specification, but
+#'   is sometimes supplied as "x-origin".
 #'
 #' @return An `info` S7 object with metadata describing a single API.
 #' @export
@@ -41,6 +46,11 @@ NULL
 #'     url = "https://opensource.org/license/apache-2-0/"
 #'   )
 #' )
+#' info(
+#'   title = "My Abbreviated API",
+#'   version = "2.0.0",
+#'   origin = "https://root.url"
+#' )
 info <- S7::new_class(
   "info",
   package = "rapid",
@@ -51,7 +61,8 @@ info <- S7::new_class(
     description = character_scalar_property("description"),
     license = license,
     summary = character_scalar_property("summary"),
-    terms_of_service = character_scalar_property("terms_of_service")
+    terms_of_service = character_scalar_property("terms_of_service"),
+    origin = class_origin
   ),
   constructor = function(title = character(),
                          version = character(),
@@ -60,7 +71,8 @@ info <- S7::new_class(
                          description = character(),
                          license = class_missing,
                          summary = character(),
-                         terms_of_service = character()) {
+                         terms_of_service = character(),
+                         origin = class_origin()) {
     check_dots_empty()
     S7::new_object(
       S7::S7_object(),
@@ -70,7 +82,8 @@ info <- S7::new_class(
       description = description %||% character(),
       license = as_license(license),
       summary = summary %||% character(),
-      terms_of_service = terms_of_service %||% character()
+      terms_of_service = terms_of_service %||% character(),
+      origin = as_origin(origin)
     )
   },
   validator = function(self) {
@@ -83,7 +96,8 @@ info <- S7::new_class(
         "description",
         "license",
         "summary",
-        "terms_of_service"
+        "terms_of_service",
+        "origin"
       )
     )
   }
@@ -101,8 +115,9 @@ S7::method(length, info) <- function(x) {
 #' @inheritParams rlang::args_dots_empty
 #' @inheritParams rlang::args_error_context
 #' @param x The object to coerce. Must be empty or have names "title",
-#'   "version", "contact", "description", "license", "summary", and/or
-#'   "terms_of_service", or names that can be coerced to those names via
+#'   "version", "contact", "description", "license", "summary",
+#'   "terms_of_service", and/or "origin" (or "x-origin", which will be coerced
+#'   to "origin"), or names that can be coerced to those names via
 #'   [snakecase::to_snake_case()]. Extra names are ignored. This object should
 #'   describe a single API.
 #'
@@ -119,7 +134,7 @@ S7::method(as_info, info) <- function(x) {
 }
 
 S7::method(as_info, class_list | class_character) <- function(x) {
-  .as_class(x, info)
+  .as_class(x, info, extra_names = c("x-origin" = "origin"))
 }
 
 S7::method(

R/zz-rapid.R

@@ -134,7 +134,12 @@ S7::method(as_rapid, class_list) <- function(x) {
 }
 
 S7::method(as_rapid, S7::new_S3_class("url")) <- function(x) {
+  url <- summary(x)$description
   x <- yaml::read_yaml(x)
+  if (!length(x$info$`x-origin`)) {
+    x$info$`x-origin` <- list(url = url)
+  }
+
   as_rapid(x)
 }
 

_pkgdown.yml

@@ -14,6 +14,8 @@ reference:
     - as_contact
     - license
     - as_license
+    - class_origin
+    - as_origin
   - title: servers class
     contents:
     - servers