#' Create a staticPath object
#'
#' The `staticPath` function creates a `staticPath` object. Note that
#' if any of the arguments (other than `path`) are `NULL`, then that
#' means that for this particular static path, it should inherit the behavior
#' from the staticPathOptions set for the application as a whole.
#'
#' The `excludeStaticPath` function tells the application to ignore a
#' particular path for static serving. This is useful when you want to include a
#' path for static serving (like `"/"`) but then exclude a subdirectory of
#' it (like `"/dynamic"`) so that the subdirectory will always be passed to
#' the R code for handling requests. `excludeStaticPath` can be used not
#' only for directories; it can also exclude specific files.
#'
#' @param path The local path.
#' @inheritParams staticPathOptions
#'
#' @seealso [staticPathOptions()].
#'
#' @export
staticPath <- function(
  path,
  indexhtml = NULL,
  fallthrough = NULL,
  html_charset = NULL,
  headers = NULL,
  validation = NULL
) {
  if (!is.character(path) || length(path) != 1 || path == "") {
    stop("`path` must be a non-empty string.")
  }

  path <- normalizePath(path, winslash = "/", mustWork = TRUE)
  path <- enc2utf8(path)

  structure(
    list(
      path = path,
      options = normalizeStaticPathOptions(staticPathOptions(
        indexhtml = indexhtml,
        fallthrough = fallthrough,
        html_charset = html_charset,
        headers = headers,
        validation = validation,
        exclude = FALSE
      ))
    ),
    class = "staticPath"
  )
}

#' @rdname staticPath
#' @export
excludeStaticPath <- function() {
  structure(
    list(
      path = "",
      options = staticPathOptions(
        indexhtml = NULL,
        fallthrough = NULL,
        html_charset = NULL,
        headers = NULL,
        validation = NULL,
        exclude = TRUE
      )
    ),
    class = "staticPath"
  )
}

#' Convert an object to a staticPath object
#'
#' This function is used to convert an object to a `staticPath` object.
#' It is primarily used internally, but can also be used by users to ensure
#' that an object is a `staticPath` object.
#'
#' @param path The object to convert.
#' @keywords internal
#' @export
as.staticPath <- function(path) {
  UseMethod("as.staticPath", path)
}

#' @export
as.staticPath.staticPath <- function(path) {
  path
}

#' @export
as.staticPath.character <- function(path) {
  staticPath(path)
}

#' @export
as.staticPath.default <- function(path) {
  stop(
    "Cannot convert object of class ",
    class(path),
    " to a staticPath object."
  )
}

#' @export
print.staticPath <- function(x, ...) {
  cat(format(x, ...), sep = "\n")
  invisible(x)
}

#' @export
format.staticPath <- function(x, ...) {
  ret <- paste0(
    "<staticPath>\n",
    "  Local path:        ",
    x$path,
    "\n",
    format_opts(x$options)
  )
}

#' Create options for static paths
#'
#'
#' @param indexhtml If an index.html file is present, should it be served up
#'   when the client requests the static path or any subdirectory?
#' @param fallthrough With the default value, `FALSE`, if a request is made
#'   for a file that doesn't exist, then httpuv will immediately send a 404
#'   response from the background I/O thread, without needing to call back into
#'   the main R thread. This offers the best performance. If the value is
#'   `TRUE`, then instead of sending a 404 response, httpuv will call the
#'   application's `call` function, and allow it to handle the request.
#' @param html_charset When HTML files are served, the value that will be
#'   provided for `charset` in the Content-Type header. For example, with
#'   the default value, `"utf-8"`, the header is `Content-Type:
#'   text/html; charset=utf-8`. If `""` is used, then no `charset`
#'   will be added in the Content-Type header.
#' @param headers Additional headers and values that will be included in the
#'   response.
#' @param validation An optional validation pattern. Presently, the only type of
#'   validation supported is an exact string match of a header. For example, if
#'   `validation` is `'"abc" = "xyz"'`, then HTTP requests must have a
#'   header named `abc` (case-insensitive) with the value `xyz`
#'   (case-sensitive). If a request does not have a matching header, than httpuv
#'   will give a 403 Forbidden response. If the `character(0)` (the
#'   default), then no validation check will be performed.
#' @param exclude Should this path be excluded from static serving? (This is
#'   only to be used internally, for [excludeStaticPath()].)
#'
#' @export
staticPathOptions <- function(
  indexhtml = TRUE,
  fallthrough = FALSE,
  html_charset = "utf-8",
  headers = list(),
  validation = character(0),
  exclude = FALSE
) {
  res <- structure(
    list(
      indexhtml = indexhtml,
      fallthrough = fallthrough,
      html_charset = html_charset,
      headers = headers,
      validation = validation,
      exclude = exclude
    ),
    class = "staticPathOptions"
  )

  normalizeStaticPathOptions(res)
}

#' @export
print.staticPathOptions <- function(x, ...) {
  cat(format(x, ...), sep = "\n")
  invisible(x)
}


#' @export
format.staticPathOptions <- function(x, ...) {
  paste0(
    "<staticPathOptions>\n",
    format_opts(x, format_empty = "<none>")
  )
}

format_opts <- function(x, format_empty = "<inherit>") {
  format_option <- function(opt) {
    if (is.null(opt) || length(opt) == 0) {
      format_empty
    } else if (!is.null(names(opt))) {
      # Named character vector
      lines <- mapply(
        function(name, value) paste0('    "', name, '" = "', value, '"'),
        names(opt),
        opt,
        SIMPLIFY = FALSE,
        USE.NAMES = FALSE
      )

      lines <- paste(as.character(lines), collapse = "\n")
      lines <- paste0("\n", lines)
      lines
    } else {
      paste(as.character(opt), collapse = " ")
    }
  }
  ret <- paste0(
    "  Use index.html:    ",
    format_option(x$indexhtml),
    "\n",
    "  Fallthrough to R:  ",
    format_option(x$fallthrough),
    "\n",
    "  HTML charset:      ",
    format_option(x$html_charset),
    "\n",
    "  Extra headers:     ",
    format_option(x$headers),
    "\n",
    "  Validation params: ",
    format_option(x$validation),
    "\n",
    "  Exclude path:      ",
    format_option(x$exclude),
    "\n"
  )
}


# This function always returns a named list of staticPath objects. The names
# will all start with "/". The input can be a named character vector or a
# named list containing a mix of strings and staticPath objects. This function
# is idempotent.
normalizeStaticPaths <- function(paths) {
  if (is.null(paths) || length(paths) == 0) {
    return(list())
  }

  if (any_unnamed(paths)) {
    stop(
      "paths must be a named character vector, a named list containing strings and staticPath objects, or NULL."
    )
  }

  if (!is.character(paths) && !is.list(paths)) {
    stop(
      "paths must be a named character vector, a named list containing strings and staticPath objects, or NULL."
    )
  }

  # Convert to list of staticPath objects. Need this verbose wrapping of
  # as.staticPath because of S3 dispatch for non-registered methods.
  paths <- lapply(paths, function(path) as.staticPath(path))

  # Make sure URL paths have a leading '/' and no trailing '/'.
  names(paths) <- vapply(
    names(paths),
    function(path) {
      path <- enc2utf8(path)

      if (path == "") {
        stop("All paths must be non-empty strings.")
      }
      # Ensure there's a leading / for every path
      if (substr(path, 1, 1) != "/") {
        path <- paste0("/", path)
      }
      # Strip trailing slashes, except when the path is just "/".
      if (path != "/") {
        path <- sub("/+$", "", path)
      }

      path
    },
    ""
  )

  paths
}

# Takes a staticPathOptions object and modifies it so that the resulting
# object is easier to work with on the C++ side. The resulting object is not
# meant to be modified on the R side. This function is idempotent; if the
# object has already been normalized, it will not be modified. For each entry,
# a NULL means to inherit.
normalizeStaticPathOptions <- function(opts) {
  if (isTRUE(attr(opts, "normalized", exact = TRUE))) {
    return(opts)
  }

  # html_charset can accept "" or character(0). But on the C++ side, we want
  # "".
  if (!is.null(opts$html_charset)) {
    if (length(opts$html_charset) == 0) {
      opts$html_charset <- ""
    }
  }

  if (!is.null(opts$exclude)) {
    if (!is.logical(opts$exclude) || length(opts$exclude) != 1) {
      stop("`exclude` option must be TRUE or FALSE.")
    }
  }

  # Can be a named list of strings, or a named character vector. On the C++
  # side, we want a named character vector.
  if (is.list(opts$headers)) {
    # Convert list to named character vector
    opts$headers <- unlist(opts$headers, recursive = FALSE)
    # Special case: if opts$headers was an empty list before unlist(), it is
    # now NULL. Replace it with an empty named character vector.
    if (length(opts$headers) == 0) {
      opts$headers <- c(a = "a")[0]
    }

    if (!is.character(opts$headers) || any_unnamed(opts$headers)) {
      stop("`headers` option must be a named list or character vector.")
    }
  }

  if (!is.null(opts$validation)) {
    if (!is.character(opts$validation) || length(opts$validation) > 1) {
      stop(
        "`validation` option must be a character vector with zero or one element."
      )
    }

    # Both "" and character(0) result in character(0). Length-1 strings other
    # than "" will be parsed.
    if (length(opts$validation) == 1) {
      if (opts$validation == "") {
        opts$validation <- character(0)
      } else {
        fail <- FALSE
        tryCatch(
          p <- parse(text = opts$validation)[[1]],
          error = function(e) fail <<- TRUE
        )
        if (!fail) {
          if (
            length(p) != 3 ||
              p[[1]] != as.symbol("==") ||
              !is.character(p[[2]]) ||
              length(p[[2]]) != 1 ||
              !is.character(p[[3]]) ||
              length(p[[3]]) != 1
          ) {
            fail <- TRUE
          }
        }
        if (fail) {
          stop(
            "`validation` must be a string of the form: '\"xxx\" == \"yyy\"'"
          )
        }

        # Turn it into a char vector for easier processing in C++
        opts$validation <- as.character(p)
      }
    }
  }

  attr(opts, "normalized") <- TRUE
  opts
}
