R functions that allow to check whether named lists are a subset of a bigger list.

are_named_lists_subset_of_other_list.R

# written as part of the sealr package: github.com/jandix/sealr

library(purrr)
#'
#' This function checks that all claims passed in the \code{claims} argument of the jwt function are
#' correct.
#' @param token JWT extracted with jose::jwt_decode_hmac.
#' @param claims named list of claims to check in the JWT. Claims can be nested.
#' @return TRUE if the all claims are present in the JWT, FALSE if not.
#' @importFrom purrr map2_lgl
#' @export

check_all_claims <- function(token, claims){

  claim_values <- claims
  claim_names <- names(claims)

  results <- purrr::map2_lgl(claim_names, claim_values, check_claim, token = token)
  return(all(results))
}


#'
#' This function checks that a claim passed to the jwt function is valid in the
#' given JWT.
#' A claim consists of a claim name (e.g. "iss") and a claim value (e.g. "company A").
#' Claim values can also be named lists themselves.
#' The function recursively extracts the value for claim_name from the token.
#' If the claim_value is atomic, it compares
#' the retrieved value with the claimed value. Otherwise, it applies check_claim
#' to claim_value recursively.
#' @param claim_name name of the claim in the JWT, e.g. "iss".
#' @param claim_value value the claim should have to pass the test.
#' @param token JWT extracted with jose::jwt_decode_hmac.
#' @return TRUE if the claim is present in the JWT, FALSE if not.
#' @importFrom purrr vec_depth map2_lgl
#' @export

check_claim <- function(claim_name, claim_value, token){

  # recursion at end, claim_value is just atomic (e.g. "Alice")
  if(purrr::vec_depth(claim_value) == 1){

    token_claim_value <- token[[claim_name]]
    # claim does not exist in token
    if (is.null(token_claim_value)) {
      return(FALSE)
    }

    # compare token value with expected value
    return(identical(token_claim_value, claim_value))

  } else {
    # claim_value is a list --> recurse
    # cannot subset token because claim_name does not exist in token
    # -> wrong claim_value
    if (!claim_name %in% names(token)){
      return(FALSE)
    }
    # recursively apply to all elements of claim_value
    return(all(c(purrr::map2_lgl(names(claim_value), claim_value, check_claim,
                                 token = token[[claim_name]]))))
  }
}


TEST_TOKEN <- list(iss = "plu",
                   user = list(
                     name = list(
                       lastname = "Smith",
                       firstname = "Alice"),
                     id = "1234",
                     admin = TRUE
                   ),
                   iat = 123456789,
                   company = list(
                     id = 1,
                     name = "a plumber company"
                   ))

check_all_claims(TEST_TOKEN, claims = list(
  user = list(admin = TRUE),
  company = list(id = 1),
  iss = "plu"
))

# FALSE
check_all_claims(TEST_TOKEN, claims = list(
  user = list(admin = TRUE, id = "5678"),
  company = list(id = 1),
  iss = "plu"
))