Реализация класса для шаблонов URL

RestRserveEndpoint.R

RestRserveEndpoint <- R6::R6Class(
  classname = "RestRserveEndpoint",
  public = list(
    path = NULL,
    method = NULL,
    regex = NULL,
    vars = NULL,
    initialize = function(path, prefix = FALSE, pattern = FALSE) {
      private$assert_path(path)
      checkmate::assert_flag(prefix)
      checkmate::assert_flag(pattern)

      # Remove '/' from the end if path is not prefix and not empty
      if (!prefix && nchar(path) > 1 && endsWith(path, "/")) {
        path <- substr(path, 1, nchar(path) - 1)
      }
      # Add '/' to the end if path is prefix
      if (prefix && !endsWith(path, "/")) {
        path <- paste0(path, "/")
      }
      self$path <- path
      private$detect_vars(path)
      if (!pattern && !is.null(self$vars)) {
        warning("Detected variables in path but 'pattern' flag is FALSE.", call. = FALSE)
      }
      if (!prefix && !pattern) {
        self$method <- "exact"
      } else if (prefix && !pattern) {
        self$method <- "partial"
      } else if (pattern && !is.null(self$vars)) {
        self$method <- "regex"
      }
    },
    match_path = function(path) {
      private$assert_path(path)
      switch(
        self$method,
        exact = identical(path, self$path),
        partial = startsWith(path, self$path),
        regex = startsWith(path, self$path) && grepl(self$regex, path)
      )
    },
    parse_vars = function(path) {
      private$assert_path(path)
      if (is.null(self$vars)) {
        return(NULL)
      }
      if (!self$match_path(path)) {
        return(NULL)
      }
      splitted <- strsplit(path, "/", fixed = TRUE)[[1]][-1]
      vals <- splitted[self$vars$pos]
      not_chr <- self$vars$type != "character"
      vals[not_chr] <- Map(function(x, cl) as(x, cl), vals[not_chr], self$vars$type[not_chr])
      names(vals) <- self$vars$name
      return(vals)
    }
  ),
  private = list(
    assert_path = function(path) {
      checkmate::assert_string(path, min.chars = 1, pattern = "/")
    },
    detect_vars = function(path) {
      # Split path
      splitted <- strsplit(path, "/", fixed = TRUE)[[1L]][-1L]
      # Detect variables positions
      pos <- which(startsWith(splitted, "{") & endsWith(splitted, "}"))
      # Exit if variables not found
      if (length(pos) == 0L) {
        return(FALSE)
      }
      # Remove '{}'
      splitted[pos] <- substr(splitted[pos], 2L, nchar(splitted[pos]) - 1L)
      # Make regex
      regex <- splitted
      regex[pos] <- "([^/]+)"
      regex <- paste0("/", paste(regex, collapse = "/"), "/?$")
      self$regex <- regex
      # Make path prefix to fast match
      path <- paste0("/", paste(splitted[seq_len(pos[1] - 1)], collapse = "/"), "/")
      self$path <- path
      # Detect variables types
      tmp <- strsplit(splitted[pos], ":", fixed = TRUE)
      vars <- data.frame(
        name = vapply(tmp, "[", 1, FUN.VALUE = character(1)),
        type = vapply(tmp, "[", 2, FUN.VALUE = character(1)),
        pos = pos,
        stringsAsFactors = FALSE
      )
      # Set default type
      vars$type[is.na(vars$type)] <- "character"
      self$vars <- vars
      return(TRUE)
    }
  )
)


path1_1 <- "/test.txt"
path1_2 <- "/test2.txt"
ep1 <- RestRserveEndpoint$new(
  path = path1_1,
  prefix = FALSE,
  pattern = FALSE
)
ep1$match_path("/")
ep1$match_path(path1_1)
ep1$match_path(path1_2)


path2_1 <- "/doc"
path2_2 <- "/doc/page1.html"
path2_3 <- "/doc3"
path2_4 <- "/doc/"
ep2 <- RestRserveEndpoint$new(
  path = path2_1,
  prefix = TRUE,
  pattern = FALSE
)
ep2$match_path("/")
ep2$match_path(path2_1)
ep2$match_path(path2_2)
ep2$match_path(path2_3)
ep2$match_path(path2_4)


path3_1 <- "/part1/{var1}/{var2:integer}/path2/{var3:character}/{var4:double}/"
path3_2 <- "/part1/text1/123456/path2/text2/3.14/"
# Should raise warning
ep3 <- RestRserveEndpoint$new(
  path = path3_1,
  prefix = FALSE,
  pattern = FALSE
)
ep3 <- RestRserveEndpoint$new(
  path = path3_1,
  prefix = FALSE,
  pattern = TRUE
)
ep3$vars
ep3$match_path("/")
ep3$match_path(path3_1)
ep3$match_path(path3_2)
ep3$parse_vars(path3_2)

RestRserveMethodHandler.R

RestRserveMethodHandler <- R6::R6Class(
  classname = "RestRserveMethodHandler",
  public = list(
    exact = NULL,
    partial = NULL,
    initialize = function() {
      self$exact <- new.env()
      self$partial <- new.env()
      private$handlers <- new.env()
      private$vars <- new.env()
    },
    size = function() {
      sum(length(self$exact), length(self$partial), length(self$regex))
    },
    add_path = function(path, match = c("exact", "partial", "regex"), fun) {
      private$assert_path(path)
      match <- match.arg(match)
      checkmate::assert_function(fun, nargs = 2L)

      # Generate UID
      id <- digest::digest(fun)

      # Prepare path
      path <- private$prepare_path(path, match)

      switch(
        match,
        "exact" = {
          if (isTRUE(checkmate::check_choice(path, names(self$exact)))) {
            stop("Path already exists.", call. = FALSE)
          }
          self$exact[[path]]$id <- id
        },
        "partial" = {
          if (isTRUE(checkmate::check_choice(path, names(self$partial)))) {
            stop("Prefix already exists.", call. = FALSE)
          }
          self$partial[[path]]$id <- id
          self$partial[[path]]$prefix <- TRUE
        },
        "regex" = {
          vars <- private$parse_vars(path)
          pattern <- attr(vars, "regex")
          prefix <- attr(vars, "prefix")
          if (!is.null(self$partial[[prefix]]$patterns) && isTRUE(checkmate::check_choice(pattern, names(self$partial[[prefix]]$patterns)))) {
            stop("Regex already exists.", call. = FALSE)
          }

          self$partial[[prefix]]$regex <- TRUE
          if (is.null(self$partial[[prefix]]$prefix)) {
            self$partial[[prefix]]$prefix <- FALSE
          }
          if (is.null(self$partial[[prefix]]$patterns)) {
            self$partial[[prefix]]$patterns <- new.env()
          }
          self$partial[[prefix]]$patterns[[pattern]]$id <- id
          private$vars[[id]] <- vars
        }
      )

      # Append paths
      private$paths <- append(private$paths, setNames(path, match))

      # Add handler
      private$handlers[[id]] <- fun
    },
    match_path = function(path) {
      private$assert_path(path)
      if (!is.null(self$exact[[path]])) {
        return(self$exact[[path]]$id)
      }
      if (length(self$partial) > 0L) {
        idx <- which(startsWith(path, names(self$partial)))
        if (length(idx) > 0L) {
          nm <- names(self$partial)[idx]
          matched <- nm[which.max(nchar(nm))]
          if (isTRUE(self$partial[[matched]]$regex)) {
            # FIXME: optimize me!
            for (pattern in names(self$partial[[matched]]$patterns)) {
              if (grepl(pattern, path)) {
                return(self$partial[[matched]]$patterns[[pattern]]$id)
              }
            }
          }
          if (isTRUE(self$partial[[matched]]$prefix)) {
            return(self$partial[[matched]]$id)
          }
        }
      }
      return(NULL)
    },
    get_handler = function(id) {
      return(private$handlers[[id]])
    },
    get_vars = function(path, id) {
      splitted <- strsplit(path, "/", fixed = TRUE)[[1L]]
      res <- structure(
        as.list(splitted[private$vars[[id]]$pos]),
        names = private$vars[[id]]$name
      )
      return(res)
    },
    print = function() {
      paths <- private$paths
      methods <- names(private$paths)
      cat("<RestRserveMethodHandler>", "\n")
      cat("  Endpoints:", "\n")
      if (any(methods == "exact")) {
        cat("    Exact match:", "\n")
        cat(paste0("      - ", paths[methods == "exact"], collapse = "\n"), "\n")
      }
      if (any(methods == "partial")) {
        cat("    Partial match:", "\n")
        cat(paste0("      - ", paths[methods == "partial"], collapse = "\n"), "\n")
      }
      if (any(methods == "regex")) {
        cat("    Regex match:", "\n")
        cat(paste0("      - ", paths[methods == "regex"], collapse = "\n"), "\n")
      }
      return(invisible(NULL))
    }
  ),
  private = list(
    paths = NULL,
    vars = NULL,
    handlers = NULL,
    assert_path = function(path) {
      checkmate::assert_string(path, min.chars = 1, pattern = "/")
    },
    prepare_path = function(path, match) {

      # Remove '/' from the end if path is not prefix and not empty
      if (match %in% c("exact", "regex") && nchar(path) > 1 && endsWith(path, "/")) {
        path <- substr(path, 1, nchar(path) - 1)
      }
      # Add '/' to the end if path is prefix
      if (match == "partial" && !endsWith(path, "/")) {
        path <- paste0(path, "/")
      }
      return(path)
    },
    find_regex_prefix = function(path) {
      # Split path
      splitted <- strsplit(path, "/", fixed = TRUE)[[1L]][-1L]
      # Detect variables positions
      pos <- which(startsWith(splitted, "{") & endsWith(splitted, "}"))
      # Exit if variables not found
      if (length(pos) == 0L) {
        stop("Can't detect variables in path template.", call. = FALSE)
      }
      # Make path prefix to fast match
      prefix <- paste0("/", paste(splitted[seq_len(pos[1] - 1)], collapse = "/"), "/")
      return(prefix)
    },
    parse_vars = function(path, start = "{", end = "}") {
      # Split path
      splitted <- strsplit(path, "/", fixed = TRUE)[[1L]][-1L]
      # Detect variables positions
      pos <- which(startsWith(splitted, start) & endsWith(splitted, end))
      # Exit if variables not found
      if (length(pos) == 0L) {
        stop("Can't detect variables.", call. = FALSE)
      }
      # Remove '{}'
      splitted[pos] <- substr(splitted[pos], 2L, nchar(splitted[pos]) - 1L)
      # Make regex
      regex <- splitted
      regex[pos] <- "([^/]+)"
      regex <- paste0("/", paste(regex, collapse = "/"), "/?$")
      # Make path prefix to fast match
      prefix <- paste0("/", paste(splitted[seq_len(pos[1] - 1)], collapse = "/"), "/")
      # Detect variables types
      tmp <- strsplit(splitted[pos], ":", fixed = TRUE)
      vars <- data.frame(
        name = vapply(tmp, "[", 1, FUN.VALUE = character(1)),
        type = vapply(tmp, "[", 2, FUN.VALUE = character(1)),
        pos = pos,
        stringsAsFactors = FALSE
      )
      # Set default type
      vars$type[is.na(vars$type)] <- "character"
      attr(vars, "prefix") <- prefix
      attr(vars, "regex") <- regex
      return(vars)
    }
  )
)