Have Some Fun with 'HTTP' Headers
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

157 lines
5.0 KiB

c(
'access-control-allow-origin',
'content-security-policy',
'expect-ct',
'feature-policy',
'server',
'public-key-pins',
'referrer-policy',
'strict-transport-security',
'x-content-type-options',
'x-frame-options',
'x-permitted-cross-domain-policies',
'x-powered-by',
'x-xss-protection'
) -> .security_headers
#' Assess "security" headers for a given URL
#'
#' @param url target URL
#' @param include_ref if `TRUE` (default: `FALSE`) the data frame will contains
#' information reference fields from [http_headers]
#' @param ... passed on to the final [httr::HEAD()] request.
#' @return data frame (tibble)
#' @export
assess_security_headers <- function(url, include_ref = FALSE, ...) {
res <- get_response_headers(url, ...)
if (length(res)) {
if (res$scheme != "https") warning("NOTE: Request not made via HTTPS", call.=FALSE)
h <- res$hdrs
lapply(.security_headers, function(.x) {
value <- h[[.x]]
status_code <- NULL
message <- NULL
if (length(value)) {
if (.x == "access-control-allow-origin") {
status_code <- "NOTE"
message = "Access-Control-Allow-Origin present"
} else if (.x == "content-security-policy") {
status_code <- "OK"
message = "NOTE: Policy present but not parse"
} else if (.x == "public-key-pins") {
if (grepl("pin-sha256", tolower(value))) {
status_code <- "OK"
message <- "Acceptable setting found"
} else {
message <- "Minimum required value ('pin-sha256') not present"
}
} else if (.x == "expect-ct") {
status_code <- "OK"
message <- "Value present but not verified"
} else if (.x == "feature-policy") {
status_code <- "OK"
message <- "Value present but not verified"
} else if (.x == "referrer-policy") {
if (tolower(value) %in% c(
"no-referrer", "no-referrer-when-downgrade", "origin",
"origin-when-cross-origin", "same-origin", "strict-origin",
"strict-origin-when-cross-origin", "unsafe-url"
)) {
status_code <- "OK"
message <- "Acceptable setting found"
} else {
status_code <- "WARN"
message = "No legitimate value present"
}
} else if (.x == "server") {
status_code <- "NOTE"
message = "Server header found"
} else if (.x == "strict-transport-security") {
if (grepl("max-age", value)) {
status_code <- "OK"
message <- "Value present but not evaluated"
} else {
status_code = "WARN"
message <- "Minimum required value ('max-age') not present"
}
} else if (.x == "x-xss-protection") {
if (value == "nosniff") {
status_code <- "OK"
message = "Acceptable setting found"
} else {
status_code <- "WARN"
message = "Required value ('nosniff') not present"
}
} else if (.x == "x-content-type-options") {
if (value == "nosniff") {
status_code <- "OK"
message = "Acceptable setting found"
} else {
status_code <- "WARN"
message = "Required value ('nosniff') not present"
}
} else if (.x == "x-frame-options") {
if (tolower(value) %in% c("deny", "sameorigin")) {
status_code = "OK"
message <- "Acceptable setting found"
} else if (any(grepl('allow-from', tolower(value)))) {
status_code <- "WARN"
message <- "Other domains are allowed to frame the site"
} else {
status_code <- "WARN"
message <- "Values 'deny' or 'sameorigin' not found"
}
} else if (.x == "x-permitted-cross-domain-policies") {
if (grepl("none|master-only|by-content-type|by-ftp-filename|all", tolower(value))) {
status_code <- "OK"
message <- "Acceptable setting found"
} else {
status_code <- "WARN"
message <- "No legitimate value present"
}
} else if (.x == "x-powered-by") {
status_code <- "NOTE"
message <- "X-Powered-By header present"
}
} else {
value <- NA_character_
status_code <- "WARN"
message <- "Header not set"
}
data.frame(
url = url,
header = .x,
value = value,
status_code = status_code,
message = message,
stringsAsFactors = FALSE
)
})
} -> out
out <- do.call(rbind.data.frame, out)
out <- out[order(out[["header"]]),]
if ((include_ref) && (nrow(out) > 0)) {
utils::data("http_headers", package = "hdrs", envir = .pkgenv)
hint <- .pkgenv$http_headers
hint[["header_field_name"]] <- tolower(hint[["header_field_name"]])
out <- merge(out, hint, by.x = "header", by.y = "header_field_name", all.x=TRUE)
}
class(out) <- c("tbl_df", "tbl", "data.frame")
out
}