1# Environment in which cookies will be stored. Cookies are expected to survive 2# the duration of the R session, but are not persisted outside of the R 3# session. 4.cookieStore <- new.env(parent=emptyenv()) 5 6# Returns the cookies associated with a particular host/port 7# If no hostname is specified, returns all cookies 8getCookies <- function(hostname, port=NULL){ 9 if (missing(hostname)){ 10 hosts <- ls(envir=.cookieStore) 11 cookies <- lapply(hosts, function(h){ 12 getCookiesHostname(h) 13 }) 14 do.call("rbind", cookies) 15 } else { 16 host <- getCookieHost(list(host=hostname, port=port)) 17 getCookiesHostname(host) 18 } 19} 20 21# Get cookies for a particular hostname(:port) 22getCookiesHostname <- function(host){ 23 if (!exists(host, .cookieStore)){ 24 NULL 25 } else { 26 cookies <- get(host, envir=.cookieStore) 27 cookies$host <- host 28 cookies 29 } 30} 31 32# Clears the cookies associated with a particular hostname/port combination. 33# If hostname and port are omitted, clears all the cookies 34clearCookies <- function(hostname, port=NULL){ 35 if (missing(hostname)){ 36 rm(list=ls(envir=.cookieStore), envir=.cookieStore) 37 } else { 38 host <- getCookieHost(list(host=hostname, port=port)) 39 rm(list=host, envir=.cookieStore) 40 } 41} 42 43userAgent <- function() { 44 paste("rsconnect", packageVersion("rsconnect"), sep="/") 45} 46 47getCookieHost <- function(requestURL){ 48 host <- requestURL$host 49 port <- requestURL$port 50 if (!is.null(port) && nchar(port) > 0){ 51 port <- sub("^:", "", port) 52 # By my reading of the RFC, we technically only need to include the port # 53 # in the index if the host is an IP address. But here we're including the 54 # port number as a part of the host whether using a domain name or IP. 55 # Erring on the side of not sending the cookies to the wrong services 56 host <- paste(host, port, sep=":") 57 } 58 host 59} 60 61# Parse out the raw headers provided and insert them into the cookieStore 62# NOTE: Domain attribute is currently ignored 63# @param requestURL the parsed URL as returned from `parseHttpUrl` 64# @param cookieHeaders a list of characters strings representing the raw 65# Set-Cookie header value with the "Set-Cookie: " prefix omitted 66storeCookies <- function(requestURL, cookieHeaders){ 67 cookies <- lapply(cookieHeaders, function(co){ parseCookie(requestURL, co) }) 68 69 # Filter out invalid cookies (which would return as NULL) 70 cookies <- Filter(Negate(is.null), cookies) 71 72 host <- getCookieHost(requestURL) 73 74 hostCookies <- NULL 75 if (!exists(host, .cookieStore)){ 76 # Create a new data frame for this host 77 hostCookies <- data.frame( 78 path=character(0), 79 name=character(0), 80 value=character(0), 81 secure=logical(0), 82 expires=character(0), 83 stringsAsFactors = FALSE 84 ) 85 } else { 86 hostCookies <- get(host, envir=.cookieStore) 87 } 88 89 lapply(cookies, function(co){ 90 # Remove any duplicates 91 # RFC says duplicate cookies are ones that have the same domain, name, and path 92 hostCookies <<- hostCookies[!(co$name == hostCookies$name & co$path == hostCookies$path),] 93 94 # append this new cookie on 95 hostCookies <<- rbind(as.data.frame(co, stringsAsFactors=FALSE), hostCookies) 96 }) 97 98 # Save this host's cookies into the cookies store. 99 assign(host, hostCookies, envir=.cookieStore) 100} 101 102# Parse out an individual cookie 103# @param requestURL the parsed URL as returned from `parseHttpUrl` 104# @param cookieHeader the raw text contents of the Set-Cookie header with the 105# header name omitted. 106parseCookie <- function(requestURL, cookieHeader){ 107 keyval <- regmatches(cookieHeader, regexec( 108 "^(\\w+)\\s*=\\s*([^;]*)(;|$)", cookieHeader, ignore.case=TRUE))[[1]] 109 if (length(keyval) == 0){ 110 # Invalid cookie format. 111 warning("Unable to parse set-cookie header: ", cookieHeader) 112 return(NULL) 113 } 114 key <- keyval[2] 115 val <- keyval[3] 116 117 # Path 118 path <- regmatches(cookieHeader, regexec( 119 "^.*\\sPath\\s*=\\s*([^;]+)(;|$).*$", cookieHeader, ignore.case=TRUE))[[1]] 120 if (length(path) == 0){ 121 path <- "/" 122 } else { 123 path <- path[2] 124 } 125 if (!substring(requestURL$path, 1, nchar(path)) == path){ 126 # Per the RFC, the cookie's path must be a prefix of the request URL 127 warning("Invalid path set for cookie on request for '", requestURL$path, "': ", cookieHeader) 128 return(NULL) 129 } 130 131 # MaxAge 132 maxage <- regmatches(cookieHeader, regexec( 133 "^.*\\sMax-Age\\s*=\\s*(-?\\d+)(;|$).*$", cookieHeader, ignore.case=TRUE))[[1]] 134 # If no maxage specified, then this is a session cookie, which means that 135 # (since our cookies only survive for a single session anyways...) we should 136 # keep this cookie around as long as we're alive. 137 expires <- Sys.time() + 10^10 138 if (length(maxage) > 0){ 139 # Compute time maxage seconds from now 140 expires <- Sys.time() + as.numeric(maxage[2]) 141 } 142 143 # Secure 144 secure <- grepl(";\\s+Secure(;|$)", cookieHeader, ignore.case=TRUE) 145 146 list(name=key, 147 value=val, 148 expires=expires, 149 path=path, 150 secure=secure) 151} 152 153# Appends a cookie header from the .cookieStore to the existing set of headers 154# @param requestURL the parsed URL as returned from `parseHttpUrl` 155# @param headers a named character vector containing the set of headers to be extended 156appendCookieHeaders <- function(requestURL, headers){ 157 host <- getCookieHost(requestURL) 158 159 if (!exists(host, .cookieStore)){ 160 # Nothing to do 161 return(headers) 162 } 163 164 cookies <- get(host, envir=.cookieStore) 165 166 # If any cookies are expired, remove them from the cookie store 167 if (any(cookies$expires < as.integer(Sys.time()))){ 168 cookies <- cookies[cookies$expires >= as.integer(Sys.time()),] 169 # Update the store, removing the expired cookies 170 assign(host, cookies, envir=.cookieStore) 171 } 172 173 if (nrow(cookies) == 0){ 174 # Short-circuit, return unmodified headers. 175 return(headers) 176 } 177 178 # Filter to only include cookies that match the path prefix 179 cookies <- cookies[substring(requestURL$path, 1, nchar(cookies$path)) == cookies$path,] 180 181 # If insecure channel, filter out secure cookies 182 if(tolower(requestURL$protocol) != "https"){ 183 cookies <- cookies[!cookies$secure,] 184 } 185 186 # TODO: Technically per the RFC we're supposed to order these cookies by which 187 # paths most specifically match the request. 188 cookieHeader <- paste(apply(cookies, 1, 189 function(x){ paste0(x["name"], "=", x["value"]) }), collapse="; ") 190 191 if (nrow(cookies) > 0){ 192 return(c(headers, cookie=cookieHeader)) 193 } else { 194 # Return unmodified headers 195 return(headers) 196 } 197} 198 199parseHttpUrl <- function(urlText) { 200 201 matches <- regexec("(http|https)://([^:/#?]+)(?::(\\d+))?(.*)", urlText) 202 components <- regmatches(urlText, matches)[[1]] 203 if (length(components) == 0) 204 stop("Invalid url: ", urlText) 205 206 url <- list() 207 url$protocol <- components[[2]] 208 url$host <- components[[3]] 209 url$port <- components[[4]] 210 url$path <- components[[5]] 211 url 212} 213 214parseHttpHeader <- function(header) { 215 split <- strsplit(header, ": ")[[1]] 216 if (length(split) == 2) 217 return (list(name = split[1], value = split[2])) 218 else 219 return (NULL) 220} 221 222parseHttpStatusCode <- function(statusLine) { 223 statusCode <- regexExtract("HTTP/[0-9]+\\.[0-9]+ ([0-9]+).*", statusLine) 224 if (is.null(statusCode)) 225 return (-1) 226 else 227 return (as.integer(statusCode)) 228} 229 230# @param request a list containing protocol, host, port, method, and path fields 231readHttpResponse <- function(request, conn) { 232 # read status code 233 resp <- readLines(conn, 1) 234 statusCode <- parseHttpStatusCode(resp[1]) 235 236 # read response headers 237 contentLength <- 0 238 contentType <- NULL 239 location <- NULL 240 setCookies <- NULL 241 repeat { 242 resp <- readLines(conn, 1) 243 if (nzchar(resp) == 0) 244 break() 245 246 header <- parseHttpHeader(resp) 247 if (!is.null(header)) 248 { 249 name <- tolower(header$name) 250 if (name == "content-type") 251 contentType <- header$value 252 if (name == "content-length") 253 contentLength <- as.integer(header$value) 254 if (name == "location") 255 location <- header$value 256 if (name == "set-cookie") 257 setCookies <- c(setCookies, header$value) 258 } 259 } 260 261 # Store the cookies that were found in the request 262 storeCookies(request, setCookies) 263 264 # read the response content 265 content <- rawToChar(readBin(conn, what = 'raw', n=contentLength)) 266 267 # emit JSON trace if requested 268 if (httpTraceJson() && identical(contentType, "application/json")) 269 cat(paste0(">> ", content, "\n")) 270 271 # return list 272 list(req = request, 273 status = statusCode, 274 location = location, 275 contentType = contentType, 276 content = content) 277} 278 279 280# internal sockets implementation of upload 281httpInternal <- function(protocol, 282 host, 283 port, 284 method, 285 path, 286 headers, 287 contentType = NULL, 288 file = NULL, 289 certificate = NULL, 290 writer = NULL, 291 timeout = NULL) { 292 293 if (!is.null(file) && is.null(contentType)) 294 stop("You must specify a contentType for the specified file") 295 296 # default port to 80 if necessary 297 if (!nzchar(port)) 298 port <- "80" 299 300 # read file in binary mode 301 if (!is.null(file)) { 302 fileLength <- file.info(file)$size 303 fileContents <- readBin(file, what="raw", n=fileLength) 304 } 305 306 # build http request 307 request <- NULL 308 request <- c(request, paste(method, " ", path, " HTTP/1.1\r\n", sep="")) 309 request <- c(request, "User-Agent: ", userAgent(), "\r\n") 310 request <- c(request, "Host: ", host, "\r\n", sep="") 311 request <- c(request, "Accept: */*\r\n") 312 if (!is.null(file)) { 313 request <- c(request, paste("Content-Type: ", 314 contentType, 315 "\r\n", 316 sep="")) 317 request <- c(request, paste("Content-Length: ", 318 fileLength, 319 "\r\n", 320 sep="")) 321 } 322 headers <- appendCookieHeaders( 323 list(protocol=protocol, host=host, port=port, path=path), headers) 324 for (name in names(headers)) 325 { 326 request <- c(request, 327 paste(name, ": ", headers[[name]], "\r\n", sep="")) 328 } 329 request <- c(request, "\r\n") 330 331 # output request if in verbose mode 332 if (httpVerbose()) 333 cat(request) 334 335 # use timeout if supplied, default timeout if not (matches parameter behavior 336 # for socketConnection) 337 timeout <- if (is.null(timeout)) getOption("timeout") else timeout 338 339 # open socket connection 340 time <- system.time(gcFirst=FALSE, { 341 conn <- socketConnection(host = host, 342 port = as.integer(port), 343 open = "w+b", 344 blocking = TRUE, 345 timeout = timeout) 346 on.exit(close(conn)) 347 348 # write the request header and file payload 349 writeBin(charToRaw(paste(request,collapse="")), conn, size=1) 350 if (!is.null(file)) { 351 writeBin(fileContents, conn, size=1) 352 } 353 354 # read the response 355 response <- readHttpResponse(list( 356 protocol = protocol, 357 host = host, 358 port = port, 359 method = method, 360 path = path), conn) 361 }) 362 httpTrace(method, path, time) 363 364 # print if in verbose mode 365 if (httpVerbose()) 366 print(response) 367 368 # output JSON if requested 369 if (httpTraceJson() && identical(contentType, "application/json")) 370 cat(paste0("<< ", rawToChar(fileContents), "\n")) 371 372 # return it 373 response 374} 375 376httpCurl <- function(protocol, 377 host, 378 port, 379 method, 380 path, 381 headers, 382 contentType = NULL, 383 file = NULL, 384 certificate = NULL, 385 writer = NULL, 386 timeout = NULL) { 387 388 if (!is.null(file) && is.null(contentType)) 389 stop("You must specify a contentType for the specified file") 390 391 if (!is.null(file)) 392 fileLength <- file.info(file)$size 393 394 headers <- appendCookieHeaders( 395 list(protocol=protocol, host=host, port=port, path=path), headers) 396 extraHeaders <- character() 397 for (header in names(headers)) 398 { 399 if(!identical(header, "Content-Type") && !identical(header, "Content-Length")){ 400 extraHeaders <- paste(extraHeaders, "--header") 401 extraHeaders <- paste(extraHeaders, 402 paste('"', header,": ",headers[[header]], '"', sep="")) 403 } 404 } 405 406 outputFile <- tempfile() 407 408 command <- paste("curl", 409 "-i", 410 "-X", 411 method); 412 413 if (httpVerbose()) 414 command <- paste(command, "-v") 415 416 if (!is.null(timeout)) 417 command <- paste(command, "--connect-timeout", timeout) 418 419 if (!is.null(file)) { 420 command <- paste(command, 421 "--data-binary", 422 shQuote(paste("@", file, sep="")), 423 "--header", paste('"' ,"Content-Type: ",contentType, '"', sep=""), 424 "--header", paste('"', "Content-Length: ", fileLength, '"', sep="")) 425 } 426 427 # add prefix to port if necessary 428 if (nzchar(port)) 429 port <- paste(":", port, sep="") 430 431 if (!isTRUE(getOption("rsconnect.check.certificate", TRUE))) { 432 # suppressed certificate check 433 command <- paste(command, "--insecure") 434 } else if (!is.null(certificate)) { 435 # cert check not suppressed and we have a supplied cert 436 command <- paste(command, 437 "--cacert", shQuote(certificate)) 438 } 439 440 command <- paste(command, 441 extraHeaders, 442 "--header", "Expect:", 443 "--user-agent", userAgent(), 444 "--silent", 445 "--show-error", 446 "-o", shQuote(outputFile), 447 paste('"', protocol, "://", host, port, path, '"', sep="")) 448 449 result <- NULL 450 time <- system.time(gcFirst = FALSE, { 451 result <- system(command) 452 }) 453 httpTrace(method, path, time) 454 455 # emit JSON trace if requested 456 if (!is.null(file) && httpTraceJson() && 457 identical(contentType, "application/json")) 458 { 459 fileLength <- file.info(file)$size 460 fileContents <- readBin(file, what="raw", n=fileLength) 461 cat(paste0("<< ", rawToChar(fileContents), "\n")) 462 } 463 464 if (result == 0) { 465 fileConn <- file(outputFile, "rb") 466 on.exit(close(fileConn)) 467 readHttpResponse(list( 468 protocol = protocol, 469 host = host, 470 port = port, 471 method = method, 472 path = path), fileConn) 473 } else { 474 stop(paste("Curl request failed (curl error", result, "occurred)")) 475 } 476} 477 478httpRCurl <- function(protocol, 479 host, 480 port, 481 method, 482 path, 483 headers, 484 contentType = NULL, 485 file = NULL, 486 certificate = NULL, 487 writer = NULL, 488 timeout = NULL) { 489 490 if (!is.null(file) && is.null(contentType)) 491 stop("You must specify a contentType for the specified file") 492 493 # add prefix to port if necessary 494 if (!is.null(port) && nzchar(port)) 495 port <- paste(":", port, sep="") 496 497 # build url 498 url <- paste(protocol, "://", host, port, path, sep="") 499 500 # read file in binary mode 501 if (!is.null(file)) { 502 fileLength <- file.info(file)$size 503 fileContents <- readBin(file, what="raw", n=fileLength) 504 headers$`Content-Type` <- contentType 505 } 506 507 # establish options 508 options <- RCurl::curlOptions(url) 509 options$useragent <- userAgent() 510 if (isTRUE(getOption("rsconnect.check.certificate", TRUE))) { 511 options$ssl.verifypeer <- TRUE 512 513 # apply certificate information if present 514 if (!is.null(certificate)) 515 options$cainfo <- certificate 516 } else { 517 # don't verify peer (less secure but tolerant to self-signed cert issues) 518 options$ssl.verifypeer <- FALSE 519 } 520 521 headerGatherer <- RCurl::basicHeaderGatherer() 522 options$headerfunction <- headerGatherer$update 523 524 # the text processing done by .mapUnicode has the unfortunate side effect 525 # of turning escaped backslashes into ordinary backslashes but leaving 526 # ordinary backslashes alone, which can create malformed JSON. 527 textGatherer <- if (is.null(writer)) 528 RCurl::basicTextGatherer(.mapUnicode = FALSE) 529 else 530 writer 531 532 # when using a custom output writer, add a progress check so we can 533 # propagate interrupts, and wait a long time (for streaming) 534 if (!is.null(writer)) { 535 options$noprogress <- FALSE 536 options$progressfunction <- writer$progress 537 options$timeout <- 9999999 538 } 539 540 # use timeout if supplied 541 if (!is.null(timeout)) { 542 options$timeout <- timeout 543 } 544 545 # verbose if requested 546 if (httpVerbose()) 547 options$verbose <- TRUE 548 549 # add extra headers 550 headers <- appendCookieHeaders( 551 list(protocol=protocol, host=host, port=port, path=path), headers) 552 extraHeaders <- as.character(headers) 553 names(extraHeaders) <- names(headers) 554 options$httpheader <- extraHeaders 555 556 # make the request 557 time <- system.time(gcFirst = FALSE, tryCatch({ 558 if (!is.null(file)) { 559 RCurl::curlPerform(url = url, 560 .opts = options, 561 customrequest = method, 562 readfunction = fileContents, 563 infilesize = fileLength, 564 writefunction = textGatherer$update, 565 upload = TRUE) 566 } else if (method == "DELETE") { 567 RCurl::curlPerform(url = url, 568 .opts = options, 569 customrequest = method) 570 571 } else { 572 if (identical(method, "GET")) { 573 RCurl::getURL(url, 574 .opts = options, 575 write = textGatherer) 576 } else { 577 RCurl::curlPerform(url = url, 578 .opts = options, 579 customrequest = method, 580 writefunction = textGatherer$update) 581 } 582 }}, 583 error = function(e, ...) { 584 # ignore errors resulting from timeout or user abort 585 if (identical(e$message, "Callback aborted") || 586 identical(e$message, "transfer closed with outstanding read data remaining")) 587 return(NULL) 588 # bubble remaining errors through 589 else 590 stop(e) 591 })) 592 httpTrace(method, path, time) 593 594 # emit JSON trace if requested 595 if (!is.null(file) && httpTraceJson() && 596 identical(contentType, "application/json")) 597 cat(paste0("<< ", rawToChar(fileContents), "\n")) 598 599 # return list 600 headers <- headerGatherer$value() 601 if ("Location" %in% names(headers)) 602 location <- headers[["Location"]] 603 else 604 location <- NULL 605 # presume a plain text response unless specified otherwise 606 contentType <- if ("Content-Type" %in% names(headers)) { 607 headers[["Content-Type"]] 608 } else { 609 "text/plain" 610 } 611 612 # Parse cookies from header; bear in mind that there may be multiple headers 613 cookieHeaders <- headers[names(headers) == "Set-Cookie"] 614 storeCookies(list(protocol=protocol, host=host, port=port, path=path), cookieHeaders) 615 616 contentValue <- textGatherer$value() 617 618 # emit JSON trace if requested 619 if (httpTraceJson() && identical(contentType, "application/json")) 620 cat(paste0(">> ", contentValue, "\n")) 621 622 list(req = list(protocol = protocol, 623 host = host, 624 port = port, 625 method = method, 626 path = path), 627 status = as.integer(headers[["status"]]), 628 location = location, 629 contentType = contentType, 630 content = contentValue) 631} 632 633httpVerbose <- function() { 634 getOption("rsconnect.http.verbose", FALSE) 635} 636 637httpTraceJson <- function() { 638 getOption("rsconnect.http.trace.json", FALSE) 639} 640 641httpTrace <- function(method, path, time) { 642 if (getOption("rsconnect.http.trace", FALSE)) { 643 cat(method, " ", path, " ", as.integer(time[['elapsed']]*1000), "ms\n", 644 sep="") 645 } 646} 647 648httpFunction <- function() { 649 httpType <- getOption("rsconnect.http", "rcurl") 650 if (identical("rcurl", httpType)) 651 httpRCurl 652 else if (identical("curl", httpType)) 653 httpCurl 654 else if (identical("internal", httpType)) 655 httpInternal 656 else 657 stop(paste("Invalid http option specified:",httpType, 658 ". Valid values are rcurl, curl, and internal")) 659} 660 661POST_JSON <- function(service, 662 authInfo, 663 path, 664 json, 665 query = NULL, 666 headers = list()) { 667 POST(service, 668 authInfo, 669 path, 670 query, 671 "application/json", 672 content = RJSONIO::toJSON(json, pretty = TRUE, digits=30), 673 headers = headers) 674} 675 676PUT_JSON <- function(service, 677 authInfo, 678 path, 679 json, 680 query = NULL, 681 headers = list()) { 682 PUT(service, 683 authInfo, 684 path, 685 query, 686 "application/json", 687 content = RJSONIO::toJSON(json, pretty = TRUE, digits=30), 688 headers = headers) 689} 690 691POST <- function(service, 692 authInfo, 693 path, 694 query = NULL, 695 contentType = NULL, 696 file = NULL, 697 content = NULL, 698 headers = list()) { 699 httpRequestWithBody(service, authInfo, "POST", path, query, contentType, file, content, headers) 700} 701 702PUT <- function(service, 703 authInfo, 704 path, 705 query = NULL, 706 contentType = NULL, 707 file = NULL, 708 content = NULL, 709 headers = list()) { 710 httpRequestWithBody(service, authInfo, "PUT", path, query, contentType, file, content, headers) 711} 712 713GET <- function(service, 714 authInfo, 715 path, 716 query = NULL, 717 headers = list(), 718 writer = NULL, 719 timeout = NULL) { 720 httpRequest(service, authInfo, "GET", path, query, headers, writer, timeout) 721} 722 723DELETE <- function(service, 724 authInfo, 725 path, 726 query = NULL, 727 headers = list(), 728 writer = NULL) { 729 httpRequest(service, authInfo, "DELETE", path, query, headers, writer) 730} 731 732httpRequestWithBody <- function(service, 733 authInfo, 734 method, 735 path, 736 query = NULL, 737 contentType = NULL, 738 file = NULL, 739 content = NULL, 740 headers = list()) { 741 742 if ((is.null(file) && is.null(content))) 743 stop("You must specify either the file or content parameter.") 744 if ((!is.null(file) && !is.null(content))) 745 stop("You must specify either the file or content parameter but not both.") 746 747 # prepend the service path 748 url <- paste(service$path, path, sep="") 749 750 # append the query 751 if (!is.null(query)) { 752 # URL encode query args 753 query <- utils::URLencode(query) 754 url <- paste(url, "?", query, sep="") 755 } 756 757 # if we have content then write it to a temp file before posting 758 if (!is.null(content)) { 759 file <- tempfile() 760 writeChar(content, file, eos = NULL, useBytes=TRUE) 761 } 762 763 # if this request is to be authenticated, sign it 764 if (!is.null(authInfo$secret) || !is.null(authInfo$private_key)) { 765 sigHeaders <- signatureHeaders(authInfo, method, url, file) 766 headers <- append(headers, sigHeaders) 767 } else { 768 headers <- append(headers, bogusSignatureHeaders()) 769 } 770 771 # perform request 772 http <- httpFunction() 773 http(service$protocol, 774 service$host, 775 service$port, 776 method, 777 url, 778 headers, 779 contentType, 780 file, 781 certificate = createCertificateFile(authInfo$certificate)) 782} 783 784httpRequest <- function(service, 785 authInfo, 786 method, 787 path, 788 query, 789 headers = list(), 790 writer = NULL, 791 timeout = NULL) { 792 793 # prepend the service path 794 url <- paste(service$path, path, sep="") 795 796 # append the query 797 if (!is.null(query)) { 798 # URL encode query args 799 query <- utils::URLencode(query) 800 url <- paste(url, "?", query, sep="") 801 } 802 803 # the request should be authenticated if there's any auth specified 804 # other than the server certificate 805 if (length(authInfo) > 0 && 806 !identical(names(authInfo), "certificate")) { 807 sigHeaders <- signatureHeaders(authInfo, method, url, NULL) 808 headers <- append(headers, sigHeaders) 809 } else { 810 headers <- append(headers, bogusSignatureHeaders()) 811 } 812 813 # perform GET 814 http <- httpFunction() 815 http(service$protocol, 816 service$host, 817 service$port, 818 method, 819 url, 820 headers, 821 writer = writer, 822 timeout = timeout, 823 certificate = createCertificateFile(authInfo$certificate)) 824} 825 826rfc2616Date <- function(time = Sys.time()) { 827 828 # capure current locale 829 loc <- Sys.getlocale('LC_TIME') 830 831 # set locale to POSIX/C to ensure ASCII date 832 Sys.setlocale("LC_TIME", "C") 833 834 # generate date 835 date <- strftime(Sys.time(), "%a, %d %b %Y %H:%M:%S GMT", tz = "GMT") 836 837 # restore locale 838 Sys.setlocale("LC_TIME", loc) 839 840 return(date) 841} 842 843urlDecode <- function(x) { 844 RCurl::curlUnescape(x) 845} 846 847urlEncode <- function(x) { 848 if (inherits(x, "AsIs")) return(x) 849 RCurl::curlEscape(x) 850} 851 852queryString <- function (elements) { 853 stopifnot(is.list(elements)) 854 elements <- elements[!sapply(elements, is.null)] 855 856 names <- RCurl::curlEscape(names(elements)) 857 values <- vapply(elements, urlEncode, character(1)) 858 if (length(elements) > 0) { 859 result <- paste0(names, "=", values, collapse = "&") 860 } else { 861 result <- "" 862 } 863 return(result) 864} 865 866bogusSignatureHeaders <- function() { 867 list(`X-Auth-Token` = 'anonymous-access') # The value doesn't actually matter here, but the header needs to be set. 868} 869 870signatureHeaders <- function(authInfo, method, path, file) { 871 # headers to return 872 headers <- list() 873 874 # remove query string from path if necessary 875 path <- strsplit(path, "?", fixed = TRUE)[[1]][[1]] 876 877 # generate date 878 date <- rfc2616Date() 879 880 if (!is.null(authInfo$secret)) { 881 # generate contents hash 882 if (!is.null(file)) 883 md5 <- digest::digest(file, algo="md5", file=TRUE) 884 else 885 md5 <- digest::digest("", algo="md5", serialize=FALSE) 886 887 # build canonical request 888 canonicalRequest <- paste(method, path, date, md5, sep="\n") 889 890 # sign request using shared secret 891 decodedSecret <- RCurl::base64Decode(authInfo$secret, mode="raw") 892 hmac <- digest::hmac(decodedSecret, canonicalRequest, algo="sha256") 893 signature <- paste(RCurl::base64Encode(hmac), "; version=1", sep="") 894 } else if (!is.null(authInfo$private_key)) { 895 # generate contents hash (this is done slightly differently for private key 896 # auth since we use base64 throughout) 897 if (!is.null(file)) 898 md5 <- digest::digest(file, algo="md5", file = TRUE, raw = TRUE) 899 else 900 md5 <- digest::digest("", algo="md5", serialize = FALSE, raw = TRUE) 901 md5 <- RCurl::base64Encode(md5) 902 903 # build canonical request 904 canonicalRequest <- paste(method, path, date, md5, sep="\n") 905 906 # sign request using local private key 907 private_key <- structure( 908 RCurl::base64Decode(authInfo$private_key, mode="raw"), 909 class="private.key.DER") 910 private_key <- PKI::PKI.load.key(what = private_key, format = "DER", 911 private = TRUE) 912 hashed <- digest::digest(object = canonicalRequest, algo = "sha1", 913 serialize = FALSE, raw = TRUE) 914 signature <- RCurl::base64Encode( 915 PKI::PKI.sign(key = private_key, digest = hashed)) 916 } else { 917 stop("can't sign request: no shared secret or private key") 918 } 919 920 # return headers 921 headers$Date <- date 922 headers$`X-Auth-Token` <- authInfo$token 923 headers$`X-Auth-Signature` <- signature 924 headers$`X-Content-Checksum` <- md5 925 headers 926} 927