Login to an Identity Provider and request resource from a Solid Pod using DPoP

solid_request.R

# Login to an Identity Provider and request resource from a Solid Pod using DPoP
# Following https://solid.github.io/solid-oidc/primer/

library(httr2)
library(jsonlite)
library(jose)

# httr2 uses req_oauth_{name} to cache access tokens from oauth_flow_{name}
# - we define req_oauth_solid_dpop
# - oauth_client has to be called manually. We instead register a client dynamically with the IDP
#   using solid_client_register_dyn
# - For the auth step, httr2 calls oauth_client_req_auth_{client$auth}.
#   We implement oauth_client_req_auth_dpop to add the dpop header and pass it as a function
# - For a request, req_perform calls auth_oauth_sign, which calls exec on the flow if needed 
#   and adds a req_auth_bearer_token
#   We need a DPoP token, not Bearer token, so can't use this approach
#   Instead, req_oauth_solid_dpop invokes the authorization itself, 
#   i.e. it does not wait for req_perform

# Modified to allow typ to be overridden
#  https://github.com/r-lib/jose/blob/master/R/jwt.R
jwt_encode_sig <- function(claim = jwt_claim(), key, size = 256, header = NULL) {
  stopifnot(inherits(claim, "jwt_claim"))
  key <- read_key(key)
  if(!inherits(key, "key"))
    stop("key must be rsa/ecdsa private key")
  # See http://tools.ietf.org/html/draft-ietf-jose-json-web-algorithms-40#section-3.4
  jwt_header <- if(inherits(key, "rsa")){
    if(as.list(key)$size < 2048)
      stop("RSA keysize must be at least 2048 bit")
    jose:::to_json(modifyList(list(
      typ = "JWT",
      alg = paste0("RS", size)
    ), header))
  } else if(inherits(key, "ecdsa")){
    # See http://tools.ietf.org/html/draft-ietf-jose-json-web-algorithms-40#section-3.4
    size <- switch(as.list(key)$data$curve,
                   "P-256" = 256, "P-384" = 384, "P-521" = 512, stop("invalid curve"))
    jose:::to_json(modifyList(list(
      typ = "JWT",
      alg = paste0("ES", size)
    ), header))
  } else {
    stop("Key must be RSA or ECDSA private key")
  }
  doc <- paste(base64url_encode(jwt_header), base64url_encode(jose:::to_json(claim)), sep = ".")
  dgst <- sha2(charToRaw(doc), size = size)
  sig <- signature_create(dgst, hash = NULL, key = key)
  if(inherits(key, "ecdsa")){
    params <- openssl::ecdsa_parse(sig)
    bitsize <- ceiling(size / 8)
    sig <- c(pad_bignum(params$r, size), pad_bignum(params$s, size))
  }
  paste(doc, base64url_encode(sig), sep = ".")
}

solid_client_register_dyn <- function(IDP){
  
  # 3. Retrieves OP Configuration
  # i.e. Fetch IDP openid configuration
  openid_config_url <- IDP
  urltools::path(openid_config_url) <- ".well-known/openid-configuration"
  configuration <- request(openid_config_url) %>% 
    req_perform() %>%
    resp_body_json()
  
  # Dynamic client registration
  # TODO: could use client doc instead?
  #  https://solid.github.io/solid-oidc/primer/#authorization-code-pkce-flow-step-7
  rego <- request(configuration$registration_endpoint) %>%
    req_body_json(list(application_type = "web", 
                       redirect_uris = list("http://localhost:1410/"),
                       subject_type = "public", 
                       token_endpoint_auth_method = "client_secret_basic", 
                       id_token_signed_response_alg = "RS256", 
                       grant_types = list("authorization_code", "refresh_token")
    )) %>%
    req_perform %>%
    resp_body_json()
  

  # 12. Generates a DPoP Client Key Pair
  key <- openssl::rsa_keygen()
  
  client <- oauth_client(rego$client_id,
                      configuration$token_endpoint,
                      auth=oauth_client_req_auth_dpop,
                      key=key
                      )
  client$authorization_endpoint <- configuration$authorization_endpoint
  client
}

# This is similar to oauth_client_req_auth_jwt_sig (auth="jwt_sig")
#  but uses a DPoP Header instead of urn:ietf:params:oauth:client-assertion-type:jwt-bearer
oauth_client_req_auth_dpop <- function(req,client){
  params <- httr2:::compact(list(client_id = client$id))
  key <- client$key
  
  # 13. Generates a DPoP Header
  jwk_pub <- parse_json(write_jwk(key$pubkey))
  
  token_claim <- jwt_claim(
    htu=client$token_url,
    htm="POST",
    jti=httr2:::base64_url_rand(32),
    iat=unclass(Sys.time())
  )
  
  token_DPoP=jwt_encode_sig(token_claim,key=key,header=list(typ="dpop+jwt",jwk=jwk_pub))
  
  # This will tell the OP what the client’s public key is
  req <- req_headers(req,DPoP=token_DPoP)
  req_body_form(req, params)
}

req_oauth_solid_dpop <- function(req,client){
  cache <- httr2:::cache_mem(client,key=NULL)
  # 4. Generates PKCE code challenge and code verifier
  # 5. Saves code verifier to session storage
  # 6. Authorization request
  # 9. Alice Logs In - opens browser window
  # 13. Generates a DPoP Header - auth="dpop"
  # 14. Token request with code and code verifier
  # Server does:
  # Skips 7. Fetch RP Client ID Document - uses dynamic registration instead
  # 8. Validate redirect url with Client ID Document - hardcoded in dynamic registration above
  # 10. Generate a code
  # 11. Send code to redirect url
  # 15. Validate code verifier
  # 16. Validates DPoP Token Signature
  # 17. Converts the DPoP public key to a JWK thumbprint
  # 18. Generates access token
  # 19. Generates the id_token
  # 20. Generates refresh token
  # 21. Sends tokens
  flow <- "oauth_flow_auth_code"
  flow_params = list(
    client = client,
    auth_url = client$authorization_endpoint,
    scope = "openid webid offline_access",
    port = 1410
  )
  
  # adapted from https://github.com/r-lib/httr2/blob/main/R/oauth.R
  token <- cache$get()
  if (is.null(token)) {
    token <- rlang::exec(flow, !!!flow_params)
  } else {
    if (httr2:::token_has_expired(token)) {
      cache$clear()
      if (is.null(token$refresh_token)) {
        token <- rlang::exec(flow, !!!flow_params)
      } else {
        token <- httr2:::token_refresh(client, token$refresh_token)
      }
    }
  }
  cache$set(token)
  
  # From here on is the equivalent of req_auth_bearer_token(req, token$access_token)
  
  key=client$key
  
  # Request flow starts
  # 1. An AJAX request is initiated
  # 2. Creates a DPoP header token
  request_claim <- jwt_claim(
    htu=req$url,
    htm=httr2:::req_method_get(req),
    jti=httr2:::base64_url_rand(32),
    iat=unclass(Sys.time())
  )
  
  jwk_pub <- parse_json(write_jwk(key$pubkey))
  # Not sure why this is needed, but it is expected by community-server via @solid/access-token-verifier
  # https://github.com/solid/access-token-verifier/blob/2090eb5d92d3c07fc43cd4c743a6afaca802bb15/src/guard/DPoPJWKGuard.ts#L64
  jwk_pub$alg <- "RS256"
  request_dpop=jwt_encode_sig(request_claim,key=key,header=list(typ="dpop+jwt",jwk=jwk_pub))
  
  # 3. Sends request
  # Server does:
  # 4. Checks Access Token expirations
  # 5. Checks the DPoP token url and method
  # 5.1. (Optional) Checks DPoP token unique identifier
  # 6. Checks DPoP signature against Access Token
  # 7. Retrieves Profile
  # 8. Checks issuer
  # 9. Retrieves OP configuration
  # 10. Requests JWKS
  # 11. Checks access token signature validity
  # 12. Performs Authorization
  # 13. Returns Result
  req %>% 
    req_headers(authorization=sprintf("DPoP %s",token$access_token)) %>% 
    req_headers(dpop=request_dpop)
}


client <- solid_client_register_dyn("http://solidcommunity.net")

# GET
url <- "https://MY_PRIVATE_URL"
request(url) %>%
  req_oauth_solid_dpop(client) %>%
  req_perform() %>%
  resp_body_string()

# PUT
url <- "https://MY_PRIVATE_URL/file.txt"
body <- "file contents"
created <- request(url) %>%
  # Needs to come before auth in order for the request to be processed as correct method
  req_method("PUT") %>%
  # If missing Content-Type header, server returns status code 400
  req_body_raw(body = body, type="text/plain") %>%
  req_oauth_solid_dpop(client) %>%
  req_perform()
created %>% resp_body_string()
etag <- created$headers$ETag

# POST - server assigns url, optionally based on Slug
url <- "https://MY_PRIVATE_URL/folder"
slug <- "newfile.txt"
body <- "file contents"
created <- request(url) %>%
  # Needs to come before auth in order for the request to be processed as correct method
  # If missing Content-Type header, server returns status code 400
  req_body_raw(body = body, type="text/plain") %>%
  # If missing, server assigns a URI to the resource
  req_headers(Slug=slug) %>%
  req_oauth_solid_dpop(client) %>%
  req_perform()
created %>% resp_body_string()
etag <- created$headers$ETag
url <- paste0(dirname(created$url),created$headers$Location)

# DELETE
deleted <- request(url) %>%
  # Needs to come before auth in order for the request to be processed as correct method
  req_method("DELETE") %>%
  req_headers("If-Match"=etag) %>%
  req_oauth_solid_dpop(client) %>%
  req_perform()
resp_status_desc(deleted)


# PUT, OPTIONS and PATCH
url <- "https://MY_PRIVATE_URL/test.ttl"
body <- "<test.ttl#this> a <test.ttl#thing> ."
created <- request(url) %>%
  # Needs to come before auth in order for the request to be processed as correct method
  req_method("PUT") %>%
  # If missing Content-Type header, server returns status code 400
  req_body_raw(body = body, type="text/turtle") %>%
  req_oauth_solid_dpop(client) %>%
  req_perform()
created %>% resp_body_string()
etag <- created$headers$ETag

opts <- request(url) %>%
  # Needs to come before auth in order for the request to be processed as correct method
  req_method("OPTIONS") %>%
  req_oauth_solid_dpop(client) %>%
  req_perform()
opts$headers
opts$headers$`Accept-Patch`

body = "INSERT DATA {<test.ttl#second> a <test.ttl#thing> .}"
update <- request(url) %>%
  # Needs to come before auth in order for the request to be processed as correct method
  req_method("PATCH") %>%
  req_headers("If-Match"=etag) %>%
  # If missing Content-Type header, server returns status code 400
  req_body_raw(body = body, type="application/sparql-update") %>%
  req_oauth_solid_dpop(client) %>%
  req_perform()
resp_status_desc(update)
etag <- update$headers$ETag

This code has been abandoned. See unmaintained R package at https://github.com/josephguillaume/solidR instead