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