Merge pull request #9 from andyquinterom/T8

Adds HTTP helpers

DESCRIPTION

@@ -1,24 +1,28 @@
 Package: tower
-Title: Easy Middle Ware Library for Shiny
+Title: Easy Middle Ware Library for 'shiny'
 Version: 0.1.0
 Authors@R: 
     c(person(given = "ixpantia, SRL",
              role = "cph",
              email = "[email protected]"),
       person("Andres", "Quintero", , "[email protected]", role = c("aut", "cre")))
-Description: The best way to implement middle ware for Shiny Applications. Tower
-    is designed to make implementing behavior on top of Shiny easy with a layering
-    model for incoming HTTP requests and server sessions. Tower is a very minimal
+Description: The best way to implement middle ware for 'shiny' Applications. 'tower'
+    is designed to make implementing behavior on top of 'shiny' easy with a layering
+    model for incoming HTTP requests and server sessions. 'tower' is a very minimal
     package with little overhead, it is mainly meant for other package developers
     to implement new behavior.
 License: MIT + file LICENSE
 Encoding: UTF-8
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.3
 Imports:
-    compiler
+    compiler,
+    glue,
+    purrr,
+    stringr,
+    curl,
+    jsonlite
 Suggests: 
     testthat (>= 3.0.0),
-    shiny,
-    stringr
+    shiny
 Config/testthat/edition: 3

NAMESPACE

@@ -1,8 +1,27 @@
 # Generated by roxygen2: do not edit by hand
 
 S3method(print,tower)
+export(add_body)
+export(add_body_json)
+export(add_cookie)
+export(add_delete_route)
+export(add_get_route)
 export(add_http_layer)
+export(add_patch_route)
+export(add_post_route)
+export(add_put_route)
+export(add_route)
 export(add_server_layer)
 export(app_into_parts)
+export(build_http_cookie)
+export(build_response)
 export(build_tower)
 export(create_tower)
+export(req_body_form)
+export(req_body_json)
+export(req_cookies)
+export(req_query)
+export(response_builder)
+export(set_content_type)
+export(set_header)
+export(set_status)

R/http_helpers.R

@@ -0,0 +1,203 @@
+#' @title Add an HTTP layer to a tower
+#' @description Adds an HTTP layer to a tower
+#' @param tower A tower object
+#' @param method A string containing the HTTP method to match
+#' @param path A string containing the path to match
+#' @param handler A function to call when the layer is matched
+#' @return A tower object with the layer added
+#' @export
+add_route <- function(tower, method = "GET", path, handler) {
+  handler <- compiler::cmpfun(handler)
+  route_handler <- compiler::cmpfun(function(req) {
+    if (req$REQUEST_METHOD == method && req$PATH_INFO == path) {
+      handler(req)
+    }
+  })
+  return(add_http_layer(tower, route_handler))
+}
+
+#' @title Add a GET route
+#' @description Adds a GET route to a tower
+#' @param tower A tower object
+#' @param path A string containing the path to match
+#' @param handler A function to call when the route is matched
+#' @return A tower object with the route added
+#' @export
+add_get_route <- function(tower, path, handler) {
+  add_route(tower, "GET", path, handler)
+}
+
+#' @title Add a POST route
+#' @description Adds a POST route to a tower
+#' @param tower A tower object
+#' @param path A string containing the path to match
+#' @param handler A function to call when the route is matched
+#' @return A tower object with the route added
+#' @export
+add_post_route <- function(tower, path, handler) {
+  add_route(tower, "POST", path, handler)
+}
+
+#' @title Add a PUT route
+#' @description Adds a PUT route to a tower
+#' @param tower A tower object
+#' @param path A string containing the path to match
+#' @param handler A function to call when the route is matched
+#' @return A tower object with the route added
+#' @export
+add_put_route <- function(tower, path, handler) {
+  add_route(tower, "PUT", path, handler)
+}
+
+#' @title Add a DELETE route
+#' @description Adds a DELETE route to a tower
+#' @param tower A tower object
+#' @param path A string containing the path to match
+#' @param handler A function to call when the route is matched
+#' @return A tower object with the route added
+#' @export
+add_delete_route <- function(tower, path, handler) {
+  add_route(tower, "DELETE", path, handler)
+}
+
+#' @title Add a PATCH route
+#' @description Adds a PATCH route to a tower
+#' @param tower A tower object
+#' @param path A string containing the path to match
+#' @param handler A function to call when the route is matched
+#' @return A tower object with the route added
+#' @export
+add_patch_route <- function(tower, path, handler) {
+  add_route(tower, "PATCH", path, handler)
+}
+
+#' @title Extract the request body from a JSON request
+#' @description Extracts the request body from a JSON request
+#' @param req A request object
+#' @param ... Additional arguments to pass to \code{\link[jsonlite]{fromJSON}}
+#'   when parsing the request body. This will only be used the first time the
+#'   request body is parsed. Subsequent calls will return the cached result.
+#' @return A list containing the request body
+#' @export
+req_body_json <- function(req, ...) {
+  if (!is.null(req[[".parsed.body.json"]])) {
+    return(req[[".parsed.body.json"]])
+  }
+  body <- tryCatch(
+    expr = jsonlite::fromJSON(
+      req$rook.input$read_lines(),
+      ...
+    ),
+    error = function(e) {
+      list()
+    }
+  )
+  req[[".parsed.body.json"]] <- body
+  return(body)
+}
+
+#' @title Extract form data from a request
+#' @description Extracts form data from a request
+#' @param req A request object
+#' @return A list containing the form data
+#' @export
+req_body_form <- function(req) {
+  if (!is.null(req[[".parsed.body.form"]])) {
+    return(req[[".parsed.body.form"]])
+  }
+  form <- tryCatch(
+    expr = shiny::parseQueryString(req[["rook.input"]]$read_lines()),
+    error = function(e) {
+      print(e)
+      list()
+    }
+  )
+  req[[".parsed.body.form"]] <- form
+  return(form)
+}
+
+#' @title Extract query parameters from a request
+#' @description Extracts query parameters from a request
+#' @param req A request object
+#' @return A list containing the query parameters
+#' @export
+req_query <- function(req) {
+  if (!is.null(req[[".parsed.query"]])) {
+    return(req[[".parsed.query"]])
+  }
+  query <- tryCatch(
+    expr = shiny::parseQueryString(req$QUERY_STRING),
+    error = function(e) {
+      list()
+    }
+  )
+  req[[".parsed.query"]] <- query
+  return(query)
+}
+
+#' @keywords internal
+split_cookie_pair <- function(.x) {
+  stringr::str_split(.x, "=", n = 2)
+}
+
+#' @keywords internal
+cookie_unescape <- function(.x) {
+  .x[2] <- curl::curl_unescape(.x[2])
+  stats::setNames(.x[2], .x[1])
+}
+
+#' @title Parse cookies
+#' @description Parses cookies from a string
+#'
+#' @param x A string containing the cookies
+#'
+#' @return A list containing the cookies
+#' @keywords internal
+parse_cookies <- function(x) {
+  if (is.null(x)) {
+    return(list())
+  }
+  cookie_pairs <- stringr::str_split(x, "; ")
+  cookie_pairs <- purrr::map(cookie_pairs, split_cookie_pair)[[1]]
+  cookie_pairs <- purrr::map(cookie_pairs, cookie_unescape)
+  cookie_pairs <- purrr::flatten(cookie_pairs)
+  return(cookie_pairs)
+}
+
+#' @keywords internal
+cookie_to_header <- function(.x, .y) {
+  list(
+    "Set-Cookie" = build_http_cookie(.y, .x)
+  )
+}
+
+#' @title Build a cookie
+#' @description Builds an HttpOnly cookie from a key and value
+#'
+#' @param key A string containing the cookie key
+#' @param value A string containing the cookie value
+#'
+#' @return A string containing the cookie
+#' @export
+build_http_cookie <- function(key, value) {
+  glue::glue("{key}={value}; path=/; SameSite=Lax; HttpOnly")
+}
+
+#' @title Extract cookies from a request
+#' @description Extracts cookies from a request
+#' @param req A request object
+#' @return A list containing the cookies
+#' @export
+req_cookies <- function(req) {
+  if (!is.null(req[[".parsed.cookies"]])) {
+    return(req[[".parsed.cookies"]])
+  }
+  cookies <- tryCatch(
+    expr = parse_cookies(req$HTTP_COOKIE),
+    error = function(e) {
+      list()
+    }
+  )
+  req[[".parsed.cookies"]] <- cookies
+  return(cookies)
+}