R/request.R

In thomasp85/reqres: Powerful Classes for HTTP Requests and Responses

#' HTTP Request Handling
#'
#' @description
#' This class wraps all functionality related to extracting information from a
#' http request. Much of the functionality is inspired by the Request class in
#' Express.js, so [the documentation](https://expressjs.com/en/4x/api.html#req)
#' for this will complement this document. As `reqres` is build on top of the
#' [Rook specifications](https://github.com/jeffreyhorner/Rook/blob/a5e45f751/README.md)
#' the `Request` object is initialized from a Rook-compliant object. This will
#' often be the request object provided by the `httpuv` framework. While it
#' shouldn't be needed, the original Rook object is always accessible and can be
#' modified, though any modifications will not propagate to derived values in
#' the `Request` object (e.g. changing the `HTTP_HOST` element of the Rook
#' object will not change the `host` field of the `Request` object). Because of
#' this, direct manipulation of the Rook object is generally discouraged.
#'
#' @usage NULL
#' @format NULL
#'
#' @section Initialization:
#' A new 'Request'-object is initialized using the \code{new()} method on the
#' generator:
#'
#' \strong{Usage}
#' \tabular{l}{
#'  \code{req <- Request$new(rook, trust = FALSE)}
#' }
#'
#' @seealso [`Response`] for handling http responses
#'
#' @importFrom R6 R6Class
#' @importFrom stringi stri_match_first_regex stri_trim_both stri_split_fixed stri_split_regex
#' @importFrom urltools url_decode
#' @importFrom brotli brotli_decompress
#' @importFrom utils modifyList
#'
#' @export
#'
#' @examples
#' fake_rook <- fiery::fake_request(
#'   'http://example.com/test?id=34632&question=who+is+hadley',
#'   content = 'This is an elaborate ruse',
#'   headers = list(
#'     Accept = 'application/json; text/*',
#'     Content_Type = 'text/plain'
#'   )
#' )
#'
#' req <- Request$new(fake_rook)
#'
#' # Get full URL
#' req$url
#'
#' # Get list of query parameters
#' req$query
#'
#' # Test if content is text
#' req$is('txt')
#'
#' # Perform content negotiation for the response
#' req$accepts(c('html', 'json', 'txt'))
#'
#' # Cleaning up connections
#' rm(fake_rook, req)
#' gc()
#'
Request <- R6Class('Request',
  lock_object = FALSE,
  public = list(
    # Methods
    #' @description Create a new request from a rook object
    #' @param rook The [rook](https://github.com/jeffreyhorner/Rook/blob/a5e45f751/README.md) object to base the request on
    #' @param trust Is this request trusted blindly. If `TRUE` `X-Forwarded-*`
    #' headers will be returned when querying host, ip, and protocol
    #' @param key A 32-bit secret key as a hex encoded string or a raw vector to
    #' use for `$encode_string()` and `$decode_string()` and by extension to
    #' encrypt a session cookie. It must be given to turn on session cookie
    #' support. A valid key can be generated using [random_key()]. NEVER STORE
    #' THE KEY IN PLAIN TEXT. Optimalle use the keyring package to store it or
    #' set it as an environment variable
    #' @param session_cookie Settings for the session cookie created using
    #' [session_cookie()]. Will be ignored if `key` is not provided to ensure
    #' session cookies are properly encrypted
    #' @param compression_limit The size threshold in bytes for trying to
    #' compress the response body (it is still dependant on content negotiation)
    #'
    initialize = function(rook, trust = FALSE, key = NULL, session_cookie = NULL, compression_limit = 0) {
      self$trust <- trust
      private$ORIGIN <- rook
      private$METHOD <- tolower(rook$REQUEST_METHOD)
      if (!is.null(key)) {
        if (!is.raw(key)) {
          check_string(key)
          key <- sodium::hex2bin(key)
        }
        if (length(key) != 32) {
          cli::cli_warn(c(
            "Ignoring key as it is not 32-bit",
            "i" = "Consider using {.fun random_key} to generate a key"
          ))
        }
      }
      private$KEY <- key
      if (!is.null(session_cookie) && !is_session_cookie_settings(session_cookie)) {
        cli::cli_warn("Ignoring malformed {.arg session_cookie} argument")
        session_cookie <- NULL
      }
      if (is.null(key) && !is.null(session_cookie)) {
        cli::cli_warn("Ignoring {.arg session_cookie} argument when {.arg key} is {.val {factor('NULL')}}")
        session_cookie <- NULL
      }
      private$SESSION_COOKIE_SETTINGS <- session_cookie
      private$HAS_SESSION_COOKIE <- !is.null(session_cookie) && isTRUE(grepl(paste0(" ", session_cookie$name, "="), rook$HTTP_COOKIE, fixed = TRUE))
      delayedAssign("HEADERS", private$get_headers(rook), assign.env = private)
      if (is.null(rook$HTTP_HOST)) {
        private$HOST <- paste(rook$SERVER_NAME, rook$SERVER_PORT, sep = ':')
      } else {
        private$HOST <- rook$HTTP_HOST
      }
      check_number_decimal(compression_limit, min = 0, allow_infinite = TRUE)
      private$COMPRESSION_LIMIT <- compression_limit
      private$PROTOCOL <- rook$rook.url_scheme
      private$ROOT <- rook$SCRIPT_NAME
      private$PATH <- rook$PATH_INFO
      private$QUERYSTRING <- rook$QUERY_STRING
      if (private$QUERYSTRING != '') {
        private$QUERYSTRING <- paste0('?', sub('^\\?', '', private$QUERYSTRING))
      }
      private$IP <- rook$REMOTE_ADDR
      delayedAssign("QUERY", private$parse_query(private$QUERYSTRING), assign.env = private)

      delayedAssign("COOKIES", private$parse_cookies(), assign.env = private)

      delayedAssign("SESSION", private$get_session_cookie(), assign.env = private)
    },
    #' @description Pretty printing of the object
    #' @param ... ignored
    #'
    print = function(...) {
      cli::cli_rule('An HTTP request')
      cli::cli_dl(c(
        Trusted = '{if (self$trust) cli::col_green("Yes") else cli::col_red("No")}',
        Method = self$method,
        URL = self$url
      ))
      invisible(self)
    },
    #' @description Sets the content of the request body. This method should
    #' mainly be used in concert with a body parser that reads the `rook$input`
    #' stream
    #' @param content An R object representing the body of the request
    #'
    set_body = function(content) {
      private$BODY <- content
      invisible(self)
    },
    #' @description Sets the cookies of the request. The cookies are
    #' automatically parsed and populated, so this method is mainly available
    #' to facilitate cookie signing and encryption
    #' @param cookies A named list of cookie values
    #'
    set_cookies = function(cookies) {
      private$COOKIES <- cookies
      invisible(self)
    },
    #' @description Given a vector of response content types it returns the
    #' preferred one based on the `Accept` header.
    #' @param types A vector of types
    #'
    accepts = function(types) {
      accept <- private$format_mimes(self$headers$accept)
      if (is.null(accept)) return(types[1])
      full_types <- private$format_types(types)
      ind <- private$get_format_spec(full_types, accept)
      if (is.null(ind)) return(NULL)
      types[ind]
    },
    #' @description Given a vector of possible character encodings it returns
    #' the preferred one based on the `Accept-Charset` header.
    #' @param charsets A vector of charsets
    #'
    accepts_charsets = function(charsets) {
      accept <- private$format_charsets(self$headers$accept_charset)
      if (is.null(accept)) return(charsets[1])
      ind <- private$get_charset_spec(tolower(charsets), accept)
      if (is.null(ind)) return(NULL)
      charsets[ind]
    },
    #' @description Given a vector of possible content encodings (usually
    #' compression algorithms) it selects the preferred one based on the
    #' `Accept-Encoding` header. If there is no match it will return `"identity"`
    #' signaling no compression.
    #' @param encoding A vector of encoding names
    #'
    accepts_encoding = function(encoding) {
      acc_enc <- self$get_header('Accept-Encoding')
      if (is.null(acc_enc)) acc_enc <- 'identity'
      accept <- private$format_encodings(acc_enc)
      ind <- private$get_encoding_spec(tolower(encoding), accept)
      if (is.null(ind)) return('identity')
      encoding[ind]
    },
    #' @description Given a vector of possible content languages it selects the
    #' best one based on the `Accept-Language` header.
    #' @param language A vector of languages
    #'
    accepts_language = function(language) {
      accept <- private$format_languages(self$headers$accept_language)
      if (is.null(accept)) return(language[1])
      ind <- private$get_language_spec(tolower(language), accept)
      if (is.null(ind)) return(NULL)
      language[ind]
    },
    #' @description Queries whether the body of the request is in a given format
    #' by looking at the `Content-Type` header. Used for selecting the best
    #' parsing method.
    #' @param type A vector of content types to check for. Can be fully
    #' qualified MIME types, a file extension, or a mime type with wildcards
    #'
    is = function(type) {
      accept <- self$get_header('Content-Type')
      if (is.null(accept)) return(NULL)
      accept <- trimws(stringi::stri_split_fixed(accept, ';', n = 2)[[1]])[1]
      content <- stringi::stri_split_fixed(accept, "/", n = 2)[[1]]
      type <- ifelse(type == "*", "*/*", type)
      ext <- !grepl('/', type)
      type[ext] <- mimes$name[mimes_ext$index[match(sub('^[.]', '', type[ext]), mimes_ext$ext)]]
      type <- stringi::stri_split_fixed(type, '/', n = 2)
      main <- vapply(type, `[[`, character(1), 1L)
      sub <- vapply(type, `[[`, character(1), 2L)
      match <- (main == content[1] | main == "*") & (sub == content[2] | sub == "*")
      priority <- order(main == "*", sub == "*", ext)
      attr(match, "pick") <- priority[which(match[priority])[1]]
      match
    },
    #' @description Get the header of the specified name.
    #' @param name The name of the header to get
    #'
    get_header = function(name) {
      self$headers[[tolower(gsub('-', '_', name))]]
    },
    #' @description Creates a new `Response` object from the request
    #'
    respond = function() {
      if (is.null(self$response)) {
        Response$new(self)
      } else {
        self$response
      }
    },
    #' @description Based on provided parsers it selects the appropriate one by
    #' looking at the `Content-Type` header and assigns the result to the
    #' request body. A parser is a function accepting a raw vector, and a named
    #' list of additional directives, and returns an R object of any kind (if
    #' the parser knows the input to be plain text, simply wrap it in
    #' [rawToChar()]). If the body is compressed, it will be decompressed based
    #' on the `Content-Encoding` header prior to passing it on to the parser.
    #' See [parsers] for a list of pre-supplied parsers. Parsers are either
    #' supplied in a named list or as named arguments to the parse method. The
    #' names should correspond to mime types or known file extensions. If
    #' `autofail = TRUE` the response will throw an appropriate abort code if
    #' failing to parse the body. `parse()` returns `TRUE` if parsing was
    #' successful and `FALSE` if not
    #' @param ... A named set of parser functions
    #' @param autofail Automatically populate the response if parsing fails
    #'
    parse = function(..., autofail = TRUE) {
      if (!private$has_body()) return(TRUE)

      parsers <- list2(...)
      if (is.list(parsers[[1]])) {
        lifecycle::deprecate_soft("0.3", I("Request$parse(list(...))"), I("Request$parse(!!!list(...))"))
        first_parsers <- names(parsers)[-1]
        parsers <- modifyList(parsers[[1]], list2(...)[-1])
        first_parsers <- names(parsers) %in% first_parsers
        parsers <- c(parsers[first_parsers], parsers[!first_parsers])
      }
      if (!is_named2(parsers)) {
        cli::cli_abort("Provided parsers must be named")
      }

      type <- self$get_header('Content-Type')
      if (is.null(type)) {
        if (autofail) {
          abort_bad_request("Missing Content-Type header")
        }
        return(FALSE)
      }

      parser_match <- self$is(names(parsers))

      if (!any(parser_match)) {
        if (autofail) {
          if (self$method == "post") {
            self$response$set_header("Accept-Post", paste0(format_types(names(parsers)), collapse = ", "))
          } else if (self$method == "patch") {
            self$response$set_header("Accept-Patch", paste0(format_types(names(parsers)), collapse = ", "))
          }
          abort_status(415L)
        }
        return(FALSE)
      }

      content <- private$get_body()
      content <- tri(private$unpack(content))
      if (is_condition(content)) {
        if (autofail) abort_bad_request("Request body failed to be decoded", parent = content)
        return(FALSE)
      }

      parser <- parsers[[attr(parser_match, "pick")]]

      directives <- trimws(strsplit(type, ';')[[1]])[-1]
      directives <- strsplit(directives, '=')
      directives <- structure(
        lapply(directives, `[`, 2),
        names = lapply(directives, `[`, 1)
      )

      content <- tri(parser(content, directives))
      if (is_reqres_problem(content)) {
        cnd_signal(content)
      } else if (is_condition(content)) {
        if (autofail) abort_status(400L, "Error parsing the request body", parent = content)
        return(FALSE)
      }

      private$BODY <- content
      return(TRUE)
    },
    #' @description This is a simpler version of the `parse()` method. It will
    #' attempt to decompress the body and set the `body` field to the resulting
    #' raw vector. It is then up to the server to decide how to handle the
    #' payload. It returns `TRUE` if successful and `FALSE` otherwise.
    #' @param autofail Automatically populate the response if parsing fails
    #'
    parse_raw = function(autofail = TRUE) {
      content <- private$get_body()
      content <- tri(private$unpack(content))
      if (is_condition(content)) {
        if (autofail) abort_bad_request("Request body failed to be decoded", parent = content)
        return(FALSE)
      }
      private$BODY <- content
      TRUE
    },
    #' @description Prints a HTTP representation of the request to the output
    #' stream.
    #'
    as_message = function() {
      cat(toupper(self$method), ' ', self$root, self$path, self$querystring, ' ', toupper(self$protocol), '/1.1\n', sep = '')
      if (is.null(self$get_header('Host'))) {
        cat('Host: ', self$host, '\n', sep = '')
      }
      headers <- split_headers(self$headers)
      cat_headers(headers$request)
      cat_headers(headers$entity)
      body <- rawToChar(private$get_body())
      cat('\n')
      if (body == '') {
        cat('<No Body>\n')
      } else {
        body <- gsub('\n', '\\\\n', body)
        body <- gsub('\t', '\\\\t', body)
        cat(substr(body, 1, 77), if (nchar(body) > 77) '...\n' else '\n', sep = '')
      }
    },
    #' @description base64-encode a string. If a key has been provided during
    #' initialisation the string is first encrypted and the final result is a
    #' combination of the encrypted text and the nonce, both base64 encoded and
    #' combined with a `"_"`.
    #' @param val A single string to encrypt
    #'
    #' @importFrom base64enc base64encode
    encode_string = function(val) {
      check_string(val)
      if (length(val) == 0) return("")
      val <- charToRaw(val)
      if (is.null(private$KEY)) {
        base64encode(val)
      } else {
        nonce <- sodium::random(24)
        val <- sodium::data_encrypt(val, private$KEY, nonce)
        paste0(base64encode(val), "_", base64encode(nonce))
      }
    },
    #' @description base64-decodes a string. If a key has been provided during
    #' initialisation the input is first split by `"_"` and then the two parts
    #' are base64 decoded and decrypted. Otherwise the input is base64-decoded
    #' as-is. It will always hold that
    #' `val == decode_string(encode_string(val))`.
    #' @param val A single string to encrypt
    #'
    #' @importFrom base64enc base64decode
    decode_string = function(val) {
      if (length(val) == 0) return(NULL)
      if (is.null(private$KEY)) {
        val <- base64decode(val)
      } else {
        val <- stringi::stri_split_fixed(val, "_", n = 2)[[1]]
        if (length(val) != 2) {
          cli::cli_warn("Failed to decode encrypted value")
          return(NULL)
        }
        val <- sodium::data_decrypt(
          base64decode(val[[1]]),
          private$KEY,
          base64decode(val[[2]])
        )
      }
      rawToChar(val)
    },
    #' @description Clears the content of the request and, if created, the
    #' related response. This method exists only to allow reuse of the request
    #' and response object to save a few milliseconds in latency. Use with
    #' caution and see e.g. how fiery maintains a poll of request objects
    clear = function() {
      private$reset_hard()
    },
    #' @description Forward a request to a new url, optionally setting different
    #' headers, queries, etc. Uses curl and mirai under the hood and returns a
    #' promise
    #' @param url The url to forward to
    #' @param query Optional querystring to append to `url`. If `NULL` the query
    #' string of the current request will be used
    #' @param method The HTTP method to use. If `NULL` the method of the current
    #' request will be used
    #' @param headers A list of headers to add to the headers of the current
    #' request. You can remove a header from the current request by setting it
    #' to `NULL` here
    #' @param body The body to send with the forward. If `NULL` the body of the
    #' current request will be used
    #' @param return A function that takes in the fulfilled response object and
    #' whose return value is returned by the promise
    #' @param ... ignored
    #'
    #' @importFrom mirai mirai
    #' @importFrom promises then
    #'
    forward = function(url, query = NULL, method = NULL, headers = NULL, body = NULL, return = NULL, ...) {
      return_fun <- return %||% identity
      if (!is.null(query) && substr(query, 1, 1) != "?") {
        query <- paste0("?", query)
      }
      url <- paste0(url, query %||% private$QUERYSTRING)
      opts <- list(
        accept_encoding = NULL
      )
      method <- toupper(method %||% private$METHOD)
      if (method == "HEAD") {
        opts$nobody <- TRUE
      } else {
        opts$customrequest <- method
      }
      body <- body %||% private$get_body() %||% raw(0)
      if (is.character(body)) {
        body <- charToRaw(body)
      }
      if (length(body) != 0) {
        opts$postfields <- body
        opts$postfieldsize <- length(body)
      }
      header_elem <- grep("^HTTP_", ls(private$ORIGIN), value = TRUE)
      cur_headers <- lapply(header_elem, function(x) private$ORIGIN[[x]])
      names(cur_headers) <- tolower(gsub("_", "-", sub("^HTTP_", "", header_elem)))
      if (!is.null(headers)) {
        names(headers) <- tolower(names(headers))
        headers <- modifyList(cur_headers, headers)
      } else {
        headers <- cur_headers
      }

      promise <- mirai::mirai(
        curl_call,
        list2env(list(opts = opts, headers = headers, url = url))
      )
      promises::then(
        promise,
        onFulfilled = function(response) {
          res <- self$respond()
          res$status <- response$status_code
          res$body <- response$content
          fwd_headers <- curl::parse_headers_list(response$headers)
          fwd_headers <- fwd_headers[!tolower(names(fwd_headers)) %in% excluded_headers]
          for (name in names(fwd_headers)) {
            res$set_header(name, fwd_headers[[name]])
          }
          res$set_data("curl_response", response)
          return_fun(res)
        },
        onRejected = function(error) {
          cli::cli_abort("Failed to forward request", parent = error)
        }
      )
    }
  ),
  active = list(
    #' @field trust A logical indicating whether the request is trusted. *Mutable*
    #'
    trust = function(value) {
      if (missing(value)) return(private$TRUST)
      check_bool(value)
      private$TRUST <- value
    },
    #' @field method A string indicating the request method (in lower case, e.g.
    #' 'get', 'put', etc.). *Immutable*
    #'
    method = function() {
      private$METHOD
    },
    #' @field body An object holding the body of the request. This is an empty
    #' string by default and needs to be populated using the `set_body()` method
    #' (this is often done using a body parser that accesses the Rook$input
    #' stream). *Immutable*
    #'
    body = function() {
      private$BODY
    },
    #' @field session The content of the session cookie. If session cookies has
    #' not been activated it will be an empty write-protected list. If session
    #' cookies are activated but the request did not contain one it will be an
    #' empty list. The content of this field will be send encrypted as part of
    #' the response according to the cookie settings in
    #' `$session_cookie_settings`. This field is reflected in the
    #' `Response$session` field and using either produces the same result
    #'
    session = function(value) {
      if (missing(value)) return(private$SESSION %||% list())
      if (is.null(private$SESSION_COOKIE_SETTINGS)) {
        cli::cli_warn(c(
          "Session cookie is not active",
          "i" = "Provide {.arg key} and {.arg session_cookie} values to turn on this feature"
        ))
      } else {
        private$SESSION <- value
      }
    },
    #' @field has_session_cookie Query whether the request came with a session
    #' cookie *Immutable*
    #'
    has_session_cookie = function() {
      private$HAS_SESSION_COOKIE
    },
    #' @field session_cookie_settings Get the settings for the session cookie as
    #' they were provided during initialisation
    #' cookie *Immutable*
    #'
    session_cookie_settings = function() {
      private$SESSION_COOKIE_SETTINGS
    },
    #' @field has_key Query whether the request was initialised with an
    #' encryption key *Immutable*
    #'
    has_key = function() {
      !is.null(private$KEY)
    },
    #' @field compression_limit Query the compression limit the request was
    #' initialized with *Immutable*
    #'
    compression_limit = function() {
      private$COMPRESSION_LIMIT
    },
    #' @field cookies Access a named list of all cookies in the request. These
    #' have been URI decoded. *Immutable*
    #'
    cookies = function() {
      private$COOKIES
    },
    #' @field headers Access a named list of all headers in the request. In
    #' order to follow R variable naming standards `-` have been substituted
    #' with `_`. Use the `get_header()` method to lookup based on the correct
    #' header name. *Immutable*
    #'
    headers = function() {
      private$HEADERS
    },
    #' @field host Return the domain of the server given by the "Host" header if
    #' `trust == FALSE`. If `trust == true` returns the `X-Forwarded-Host`
    #' instead. *Immutable*
    #'
    host = function() {
      if (self$trust && !is.null(self$headers$x_forwarded_host)) {
        self$headers$x_forwarded_host
      } else {
        private$HOST
      }
    },
    #' @field ip Returns the remote address of the request if `trust == FALSE`.
    #' If `trust == TRUE` it will instead return the first value of the
    #' `X-Forwarded-For` header. *Immutable*
    #'
    ip = function() {
      if (self$trust && !is.null(self$headers$x_forwarded_for)) {
        self$headers$x_forwarded_for[1]
      } else {
        private$IP
      }
    },
    #' @field ips If `trust == TRUE` it will return the full list of ips in the
    #' `X-Forwarded-For` header. If `trust == FALSE` it will return an empty
    #' vector. *Immutable*
    #'
    ips = function() {
      if (self$trust && !is.null(self$headers$x_forwarded_for)) {
        self$headers$x_forwarded_for
      } else {
        character(0)
      }
    },
    #' @field protocol Returns the protocol (e.g. 'http') used for the request.
    #' If `trust == TRUE` it will use the value of the `X-Forwarded-Proto` header.
    #' *Immutable*
    #'
    protocol = function() {
      if (self$trust && !is.null(self$headers$x_forwarded_proto)) {
        self$headers$x_forwarded_proto
      } else {
        private$PROTOCOL
      }
    },
    #' @field root The mount point of the application receiving this request.
    #' Can be empty if the application is mounted on the server root.
    #' *Immutable*
    #'
    root = function() {
      private$ROOT
    },
    #' @field path The part of the url following the root. Defines the local
    #' target of the request (independent of where it is mounted). *Immutable*
    #'
    path = function() {
      private$PATH
    },
    #' @field url The full URL of the request. *Immutable*
    url = function() {
      paste0(self$protocol, '://',
             self$host,
             self$root,
             self$path,
             self$querystring)
    },
    #' @field query The query string of the request (anything following "?" in
    #' the URL) parsed into a named list. The query has been url decoded and "+"
    #' has been substituted with space. Multiple queries are expected to be
    #' separated by either "&" or "|". *Immutable*
    #'
    query = function() {
      private$QUERY
    },
    #' @field query_delim The delimiter used for specifying multiple values in a
    #' query. If `NULL` then queries are expected to contain multiple key-value
    #' pairs for the same key in order to provide an array, e.g.
    #' `?arg1=3&arg1=7`. If setting it to `",""`, `"|"`, or `" "` then an array
    #' can be provided in a single key-value pair, e.g. `?arg1=3|7`
    #'
    query_delim = function(value) {
      if (missing(value)) return(private$QUERYDELIM)
      if (!is.null(value)) value <- arg_match0(value, c(",", "|", " "))
      private$QUERYDELIM <- value
      delayedAssign("QUERY", private$parse_query(private$QUERYSTRING), assign.env = private)
    },
    #' @field querystring The unparsed query string of the request, including
    #' "?". If no query string exists it will be `""` rather than `"?"`
    #'
    querystring = function() {
      private$QUERYSTRING
    },
    #' @field xhr A logical indicating whether the `X-Requested-With` header
    #' equals `XMLHttpRequest` thus indicating that the request was performed
    #' using JavaScript library such as jQuery. *Immutable*
    #'
    xhr = function() {
      xhr <- self$get_header('X-Requested-With')
      !is.null(xhr) && xhr == 'XMLHttpRequest'
    },
    #' @field secure A logical indicating whether the request was performed
    #' using a secure connection, i.e. `protocol == 'https'`. *Immutable*
    secure = function() {
      self$protocol == 'https'
    },
    #' @field origin The original object used to create the `Request` object. As
    #' `reqres` currently only works with rook this will always return the
    #' original rook object. Changing this will force the request to reparse
    #' itself.
    #'
    origin = function(value) {
      if (missing(value)) return(private$ORIGIN)
      if (!identical(private$ORIGIN, value)) {
        cli::cli_abort("It is not allowed to replace the origin store")
      }
      private$ORIGIN <- value
      private$reset()
    },
    #' @field response If a `Response` object has been created for this request
    #' it is accessible through this field. *Immutable*
    #'
    response = function(res) {
      if (missing(res)) return(private$RESPONSE)
      if (!is.null(private$RESPONSE)) {
        cli::cli_abort('Response can only be assigned once')
      }
      if (!inherits(res, 'Response')) {
        cli::cli_abort('{.arg res} must be a {.cls Response} object')
      }
      if (!identical(self, res$request)) {
        cli::cli_abort('{.arg res} must be a Response responding to this request')
      }
      private$RESPONSE <- res
    },
    #' @field locked Set the `locked` status on the request. This flag does not
    #' result in any different behaviour in the request but can be used by
    #' frameworks to signal that the request should not be altered in some way
    #'
    locked = function(value) {
      if (missing(value)) return(private$LOCKED)
      check_bool(value)
      private$LOCKED <- value
    }
  ),
  private = list(
    TRUST = FALSE,
    ORIGIN = NULL,
    METHOD = NULL,
    KEY = NULL,
    HOST = NULL,
    PROTOCOL = NULL,
    ROOT = NULL,
    PATH = NULL,
    QUERYSTRING = NULL,
    QUERYDELIM = NULL,
    IP = NULL,
    QUERY = NULL,
    BODY = NULL,
    HEADERS = NULL,
    COOKIES = NULL,
    SESSION = NULL,
    SESSION_COOKIE_SETTINGS = NULL,
    HAS_SESSION_COOKIE = FALSE,
    COMPRESSION_LIMIT = 0,
    RESPONSE = NULL,
    LOCKED = FALSE,

    reset_hard = function() {
      private$TRUST <- FALSE
      private$ORIGIN <- NULL
      private$METHOD <- NULL
      private$KEY <- NULL
      private$HOST <- NULL
      private$PROTOCOL <- NULL
      private$ROOT <- NULL
      private$PATH <- NULL
      private$QUERYSTRING <- NULL
      private$QUERYDELIM <- NULL
      private$IP <- NULL
      private$QUERY <- NULL
      private$BODY <- NULL
      private$HEADERS <- NULL
      private$COOKIES <- NULL
      private$SESSION <- NULL
      private$SESSION_COOKIE_SETTINGS <- NULL
      private$HAS_SESSION_COOKIE <- FALSE
      private$COMPRESSION_LIMIT <- 0
      if (!is.null(private$RESPONSE)) {
        private$RESPONSE$reset()
      }
    },
    parse_cookies = function() {
      if (is.null(self$headers$cookie)) return(list())
      cookies <- stri_trim_both(stri_split_regex(self$headers$cookie, ";(?=\\s*[a-zA-Z0-9!#$%&'()*+-.\\/:<>?@\\[\\]^_`{|}~]{1,})")[[1]])
      cookies <- unlist(stri_split_fixed(cookies, '=', n = 2))
      structure(
        as.list(url_decode(cookies[c(FALSE, TRUE)])),
        names = cookies[c(TRUE, FALSE)]
      )
    },
    parse_query = function(query) {
      query_parser(query, private$QUERYDELIM)
    },
    get_headers = function(rook) {
      vars <- ls(rook)
      headers <- vars[grepl('^HTTP_', vars)]
      ans <- lapply(headers, function(head) {
        # FIXME: This doesn't detect if the escape has been escaped
        literals <- stringi::stri_locate_all_regex(rook[[head]], "(?<!\\\\)\".*?[^\\\\]\"", omit_no_match = TRUE)[[1]]
        if (length(literals) == 0) {
          stringi::stri_split_regex(rook[[head]], "(?<!Mon|Tue|Wed|Thu|Fri|Sat|Sun),\\s?")[[1]]
        } else {
          splits <- stringi::stri_locate_all_regex(rook[[head]], "(?<!Mon|Tue|Wed|Thu|Fri|Sat|Sun),\\s?", omit_no_match = TRUE)[[1]]
          if (length(splits) == 0) {
            return(rook[[head]])
          }
          split_ind <- rep(seq_len(nrow(splits)), each = nrow(literals))
          splits2 <- splits[split_ind, ]
          inside <- splits2[,1] > literals[,1] & splits2[,2] < literals[,2]
          splits <- splits[-split_ind[inside],, drop = FALSE]
          if (length(splits) == 0) {
            return(rook[[head]])
          }
          splits <- c(0, t(splits) + c(-1, 1), stringi::stri_length(rook[[head]]))
          stringi::stri_sub_all(rook[[head]], splits[c(TRUE, FALSE)], splits[c(FALSE, TRUE)])[[1]]
        }
      })
      names(ans) <- tolower(sub('^HTTP_', '', headers))
      ans
    },
    format_mimes = function(type) {
      if (is.null(type) || length(type) == 0) return(NULL)
      type <- stri_match_first_regex(tolower(type), '^\\s*([^\\s\\/;]+)\\/([^;\\s]+)\\s*(?:;(.*))?$')
      type <- as.data.frame(type, stringsAsFactors = FALSE)
      names(type) <- c('full', 'main', 'sub', 'q')
      type$q <- get_quality(type$q)
      type
    },
    format_charsets = function(charsets) {
      if (is.null(charsets) || length(charsets) == 0) return(NULL)
      charsets <- stri_match_first_regex(tolower(charsets), '^\\s*([^\\s;]+)\\s*(?:;(.*))?$')
      charsets <- as.data.frame(charsets, stringsAsFactors = FALSE)
      names(charsets) <- c('full', 'main', 'q')
      charsets$q <- get_quality(charsets$q)
      charsets
    },
    format_encodings = function(encodings) {
      if (is.null(encodings) || length(encodings) == 0) return(NULL)
      encodings <- stri_match_first_regex(tolower(encodings), '^\\s*([^\\s;]+)\\s*(?:;(.*))?$')
      encodings <- as.data.frame(encodings, stringsAsFactors = FALSE)
      names(encodings) <- c('full', 'main', 'q')
      encodings$q <- get_quality(encodings$q)
      if (!'identity' %in% encodings$main) {
        encodings  <- rbind(
          encodings,
          data.frame(full = 'identity;q=0', main = 'identity', q = min(encodings$q), stringsAsFactors = FALSE)
        )
      }
      encodings
    },
    format_languages = function(lang) {
      if (is.null(lang) || length(lang) == 0) return(NULL)
      lang <- stri_match_first_regex(tolower(lang), '^\\s*([^\\s\\-;]+)(?:-([^\\s;]+))?\\s*(?:;(.*))?$')
      lang <- as.data.frame(lang, stringsAsFactors = FALSE)
      names(lang) <- c('full', 'main', 'sub', 'q')
      lang$q <- get_quality(lang$q)
      lang$complete <- paste0(lang$main, ifelse(is.na(lang$sub), '', paste0('-', lang$sub)))
      lang
    },
    format_types = function(formats) {
      ext <- !grepl('/', formats)
      format_ind <- rep(NA_integer_, length(formats))
      formats[ext] <- sub('^[.]', '', formats[ext])
      format_ind[ext] <- mimes_ext$index[match(formats[ext], mimes_ext$ext)]
      format_ind[!ext] <- match(formats[!ext], mimes$name)
      mimes[na.omit(format_ind), ]
    },
    get_format_spec = function(format, accepts) {
      f_split <- strsplit(format$name, '/')
      spec <- do.call(rbind, lapply(f_split, function(n) {
        spec <- ifelse(n[1] == accepts$main, 4, ifelse(accepts$main == '*', 0, NA))
        spec <- spec + ifelse(n[2] == accepts$sub, 2, ifelse(accepts$sub == '*', 0, NA))
        win <- order(spec, accepts$q, -seq_along(spec), decreasing = TRUE)[1]
        if (is.na(spec[win])) {
          c(NA, NA)
        } else {
          c(spec[win], win)
        }
      }))
      if (all(is.na(spec[, 1]))) return(NULL)
      order(accepts$q[spec[,2]], spec[,1], -spec[,2], -seq_along(f_split), decreasing = TRUE)[1]
    },
    get_charset_spec = function(charset, accepts) {
      spec <- do.call(rbind, lapply(charset, function(n) {
        spec <- ifelse(n == accepts$main, 1, ifelse(accepts$main == '*', 0, NA))
        win <- order(spec, accepts$q, -seq_along(spec), decreasing = TRUE)[1]
        if (is.na(spec[win])) {
          c(NA, NA)
        } else {
          c(spec[win], win)
        }
      }))
      if (all(is.na(spec[, 1]))) return(NULL)
      order(accepts$q[spec[,2]], spec[,1], -spec[,2], -seq_along(charset), decreasing = TRUE)[1]
    },
    get_encoding_spec = function(encoding, accepts) {
      spec <- do.call(rbind, lapply(encoding, function(n) {
        spec <- ifelse(n == accepts$main, 1, ifelse(accepts$main == '*', 0, NA))
        win <- order(spec, accepts$q, -seq_along(spec), decreasing = TRUE)[1]
        if (is.na(spec[win])) {
          c(NA, NA)
        } else {
          c(spec[win], win)
        }
      }))
      if (all(is.na(spec[, 1]))) return(NULL)
      order(accepts$q[spec[,2]], spec[,1], -spec[,2], -seq_along(encoding), decreasing = TRUE)[1]
    },
    get_language_spec = function(lang, accepts) {
      l_split <- strsplit(lang, '-')
      spec <- do.call(rbind, lapply(seq_along(lang), function(i) {
        spec <- ifelse(lang[i] == accepts$complete, 4, NA)
        spec <- ifelse(is.na(spec) & lang[i] == accepts$main, 2, NA)
        spec <- ifelse(is.na(spec) & l_split[[i]][1] == accepts$complete, 1, NA)
        spec <- ifelse(is.na(spec) & accepts$complete == '*', 0, NA)
        win <- order(spec, accepts$q, -seq_along(spec), decreasing = TRUE)[1]
        if (is.na(spec[win])) {
          c(NA, NA)
        } else {
          c(spec[win], win)
        }
      }))
      if (all(is.na(spec[, 1]))) return(NULL)
      order(accepts$q[spec[,2]], spec[,1], -spec[,2], -seq_along(lang), decreasing = TRUE)[1]
    },
    unpack = function(raw) {
      compression <- self$get_header('Content-Encoding')
      if (is.null(compression)) return(raw)
      compression <- rev(trimws(strsplit(compression, ',')[[1]]))
      Reduce(function(l, r) {
        switch(
          r,
          identity = l,
          br = brotli_decompress(l),
          gzip =,
          "x-gzip" = {
            con <- gzcon(rawConnection(l))
            on.exit(close(con), add = TRUE)
            readBin(con, "raw", length(l))
          },
          deflate = memDecompress(l, type = 'gzip'),
          cli::cli_abort('Unsupported compression {.val {r}}')
        )
      }, x = compression, init = raw)
    },
    has_body = function() {
      first <- private$ORIGIN$rook.input$read(1)
      private$ORIGIN$rook.input$rewind()
      length(first) != 0
    },
    get_body = function() {
      body <- private$ORIGIN$rook.input$read()
      private$ORIGIN$rook.input$rewind()
      body
    },
    get_session_cookie = function() {
      if (!private$HAS_SESSION_COOKIE) {
        return(list())
      }
      val <- self$decode_string(
        private$COOKIES[[private$SESSION_COOKIE_SETTINGS$name]]
      )
      if (is.null(val)) return(list())
      try_fetch(
        jsonlite::fromJSON(val),
        error = function(e) {
          cli::cli_warn("Failed to decode session cookie")
          list()
        }
      )
    },
    reset = function() {
      private$METHOD <- tolower(private$ORIGIN$REQUEST_METHOD)
      delayedAssign("HEADERS", private$get_headers(private$ORIGIN), assign.env = private)
      if (is.null(private$ORIGIN$HTTP_HOST)) {
        private$HOST <- paste(private$ORIGIN$SERVER_NAME, private$ORIGIN$SERVER_PORT, sep = ':')
      } else {
        private$HOST <- private$ORIGIN$HTTP_HOST
      }
      private$PROTOCOL <- private$ORIGIN$rook.url_scheme
      private$ROOT <- private$ORIGIN$SCRIPT_NAME
      private$PATH <- private$ORIGIN$PATH_INFO

      if (private$QUERYSTRING != private$ORIGIN$QUERY_STRING) {
        private$QUERYSTRING <- private$ORIGIN$QUERY_STRING
        if (private$QUERYSTRING != '') {
          private$QUERYSTRING <- paste0('?', sub('^\\?', '', private$QUERYSTRING))
        }
        private$IP <- private$ORIGIN$REMOTE_ADDR
        delayedAssign("QUERY", private$parse_query(private$QUERYSTRING), assign.env = private)
      }

      delayedAssign("COOKIES", private$parse_cookies(), assign.env = private)

      delayedAssign("SESSION", private$get_session_cookie(), assign.env = private)
    }
  )
)
#' @rdname Request
#'
#' @usage as.Request(x, ...)
#' @param x An object coercible to a `Request`.
#' @param ... Parameters passed on to `Request$new()`
#' @return A `Request` object (for `as.Request()`) or a logical indicating whether
#' the object is a `Request` (for `is.Request()`)
#' @export
as.Request <- function(x, ...) {
  UseMethod('as.Request')
}
#' @export
as.Request.Request <- function(x, ...) x
#' @export
as.Request.environment <- function(x, ...) {
  if (is.null(x[['rook.version']])) {
    cli::cli_abort('{.arg x} must be a Rook object')
  }
  Request$new(x, ...)
}
#' @rdname Request
#' @usage is.Request(x)
#' @export
is.Request <- function(x) inherits(x, 'Request')
#' @importFrom stringi stri_extract_first_regex
get_quality <- function(q) {
  q <- stri_extract_first_regex(q, 'q=([0-9]*[.])?[0-9]+')
  q <- as.numeric(sub('q=', '', q))
  q[is.na(q)] <- 1
  q
}

curl_call <- quote({
  curl_handle <- curl::new_handle()
  curl::handle_setopt(curl_handle, .list = opts)
  curl::handle_setheaders(curl_handle, .list = headers)
  curl::curl_fetch_memory(url, curl_handle)
})

excluded_headers <- c(
  "connection",
  "transfer-encoding",
  "keep-alive",
  "upgrade"
)