Merge pull request #1054 from rstudio/token_signing_workaround

sha1 token signing workaround
rstudio · Mar 22, 2024 · ae514c4 · ae514c4
2 parents 81b18c9 + 06b40f0
commit ae514c4
Show file tree

Hide file tree

Showing 5 changed files with 68 additions and 6 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -26,6 +26,7 @@ Imports:
     jsonlite,
     lifecycle,
     openssl (>= 2.0.0),
+    PKI,
     packrat (>= 0.6),
     renv (>= 1.0.0),
     rlang (>= 1.0.0),

diff --git a/NEWS.md b/NEWS.md
@@ -1,5 +1,8 @@
 # rsconnect (development version)
 
+* Use internally computed SHA1 sums and PKI signing when SHA1 is disabled 
+  in FIPS mode (#768, #1054)
+
 # rsconnect 1.2.1
 
 * Restore the `LC_TIME` locale after computing an RFC-2616 date. (#1035)

diff --git a/R/http.R b/R/http.R
@@ -501,9 +501,7 @@ signatureHeaders <- function(authInfo, method, path, file = NULL) {
       der = TRUE
     )
 
-    # OpenSSL defaults to sha1 hash function (which is what we need)
-    rawsig <- openssl::signature_create(charToRaw(canonicalRequest), key = private_key)
-    signature <- openssl::base64_encode(rawsig)
+    signature <- signRequestPrivateKey(private_key, canonicalRequest)
   } else {
     stop("can't sign request: no shared secret or private key")
   }
@@ -516,6 +514,20 @@ signatureHeaders <- function(authInfo, method, path, file = NULL) {
   headers
 }
 
+signRequestPrivateKey <- function(private_key, canonicalRequest) {
+  # convert key into PKI format for signing, note this only accepts RSA, but
+  # that's what rsconnect generates already
+  pem <- openssl::write_pem(private_key)
+  pem_lines <- readLines(textConnection(pem))
+  pki_key <- PKI::PKI.load.key(pem_lines, format = "PEM")
+
+  # use sha1 digest and then sign. digest and PKI avoid using system openssl which
+  # can be problematic in strict FIPS environments
+  digested <- digest::digest(charToRaw(canonicalRequest), "sha1", serialize = FALSE, raw = TRUE)
+  rawsig <- PKI::PKI.sign(key = pki_key, digest = digested)
+  openssl::base64_encode(rawsig)
+}
+
 rfc2616Date <- function(time = Sys.time()) {
   # set locale to POSIX/C to ensure ASCII date
   old <- Sys.getlocale("LC_TIME")

diff --git a/tests/testthat/_snaps/http.md b/tests/testthat/_snaps/http.md
@@ -22,7 +22,7 @@
     Output
       List of 3
        $ Date              : chr "Thu, 09 Mar 2023 14:29:00 GMT"
-       $ X-Auth-Signature  : chr "tqz4HGcSmuWKIGzIj42OEkwYZQzfJBdrUynlBQKSEEok2zMFZwsgEpEzU8PzpoeMEmcX5+Cr1IuDLLASz0ivAQ=="
+       $ X-Auth-Signature  : chr "mk4e1sdK0Gy9Uex2nJMtkntdT/boQWRakSRB6iYw9hmP2zMHQjvynY+Kc5hqbGAK7tbzG52fC+5MQSOUapNKBF6GNnVe1cp2jFq4pmhEL2yhlkB"| __truncated__
        $ X-Content-Checksum: chr "1B2M2Y8AsgTpgAmY7PhCfg=="
 
 # includes body in error if available

diff --git a/tests/testthat/test-http.R b/tests/testthat/test-http.R
@@ -22,13 +22,59 @@ test_that("authHeaders() picks correct method based on supplied fields", {
   )
 
   # Dummy key created with
-  # openssl::base64_encode(openssl::ed25519_keygen())
-  key <- "MC4CAQAwBQYDK2VwBCIEIDztfEgkp5CX7Jz0NCyrToaRW1L2tfmrWxNDgYyjO9bQ"
+  # openssl::base64_encode(openssl::rsa_keygen(2048L))
+  key_string <- "-----BEGIN PRIVATE KEY-----
+MIIEvgIBADANBgkqhkiG9w0BAQEFAASCBKgwggSkAgEAAoIBAQC/eiSQAKXADslq
+GGsbsQu2eEgEHD06BtUhaeU1nvsY7a6u12xpG0OAGYWhnGhR+1K/3qoZQQNmN0MC
+ZV0zhueREu3YaqtNwXbnbGCqp7tsLsx2cb2TZscmBNXkOLah2PlsBTfInNlKrpKH
+wsMtsL7yruXwJ767ey8JujMAqO90jj57idfhkr4IU47EL8DiIHTOAYLddKe/d4AL
+skoEFQM37SJ9JUwZUsvz2eqEXFPV4QrS93T79sA7QfH5zOYTLKPEDxV0U7AYUVKW
+bBieVRlu3DIQfdsqXwYYzHUR+HBlxe1VowCS5p5c6coNLdb+RElcSSY2Gd06eBg0
+wSoxkyT3AgMBAAECggEAHmQinYCczkkKiv5pMbH+K+4XcB+TUDx5Y55NNR+Qtzoy
+eanTmTMsmY5zeV076Zc8YRvUX8HD6ltnFWBFVMJaytn4SltT6TmFx+GZzjxlMRyU
+c1BGSLkNbulhkaG2yyWHITAK1Jqgmovu0gGFvSDKjfZYpK+KRHOe2apmIfquVw9d
+6CLm7swx30x8qFKEACc3iM/Mcc9uKOWn+NjVKqUVfU/9ZmNxmjZ9e3wkwieI1mSB
+gq9q7fmCHHkGWbUkGMphgRyssaJbz+bn/Wz2uwevvtebkTOzvWtKhUGgDByCCCtq
+J1ehPCjdRjylb6C5tLbyeng5QnYC7uZJmRsEOUwMEQKBgQD6PsHXwKJ8JRlDGu4G
+JQ9fKzYA+B+No0GKtGuuRDD8tJouj5rb1dZt181UHUW/UtjNpz8j8l1RN2gPcu/v
+VjwSXDcZHohv4cgQfRCN47wREEEb/LP/fhxIt2H320vh5qvwdJJoGvGoJfR5vO1X
+ysdIPBajIgnEo4U7cawaNfeS1QKBgQDD4WgXUb0AYvK6lggVVqgNzxxMQRWCQSGb
+y4RISHlC2TpftpbLFdr6fHuf8bzGq462xG5MFMMGBsbESXKNW18QA+uIBIDwttaj
+AfQ4+PNu4m+2Ump+RcGu2MYoBJoxjMx00Ba76cEMF0+X+RO4zcfwZ6Y869Fakq+D
+7rn4ZetGmwKBgQCMtgsjeUMkUWwCCrt6ow4gslh8dQixCPKKvuapp9hv0FG+CqvG
+H1iijSz8tjUI3tnf0cI0QUztpR0TSsrVpoTCwi2NJ1kKqEdp1hkf38VZRu2FgjPo
+Xw4iaVNiHmJt1NorrDDC7xuhNC5i4bQHoJMr7/W+px4c/uGkykc+ucfLPQKBgQCG
+/E/KOibgHFAfawLZCaW4FnDuz68t2wp5HY/kbCU8fwxuJxrVixMjqSNcfq9TzagE
+pWtI/MnE3midnevWJBBnrfvi+Q+OUsGpBdCybkT7tgm8ACGpMRMfFf3AWCOWX+wJ
+19jC2HyTg4DzPs9rfEv7jMIPm4bjPtC7P4li94FiXwKBgBTh5tPUEvG0chZvqRT2
+g0vvWgJGF52FCXBij3dnNl1eNRQYbDI+hNbZYcHCKHKaOoDWaqYhyjLk6Tz0LhLe
+XWAlOP6tE2UbEgi10wyaEI9EyfXg1mgiHlSg+oZMCx05TUE6PrzddS6qUOJfN7P3
+a3hEFijsjg/+FDMr+iAVzjry
+-----END PRIVATE KEY-----"
+  key <- openssl::base64_encode(openssl::read_key(key_string))
 
   expect_snapshot({
     str(authHeaders(list(secret = "123"), url, "GET"))
     str(authHeaders(list(private_key = key), url, "GET"))
   })
+
+  # and that signRequestPrivateKey() is the same as openssl equivalent
+  # authHeaders does this conversion internally
+  private_key <- openssl::read_key(
+    openssl::base64_decode(key),
+    der = TRUE
+  )
+
+  # an alternative implementation with openssl
+  signRequestPrivateKeyOpenSSL <- function(private_key, canonicalRequest) {
+    rawsig <- openssl::signature_create(charToRaw(canonicalRequest), key = private_key)
+    openssl::base64_encode(rawsig)
+  }
+
+  expect_identical(
+    signRequestPrivateKey(private_key, url),
+    signRequestPrivateKeyOpenSSL(private_key, url)
+  )
 })
 
 test_that("can add user specific headers", {