add shinyapp.service_url option

R/http.R

@@ -78,7 +78,9 @@ readHttpResponse <- function(path, conn) {
 
 
 # internal sockets implementation of upload
-httpInternal <- function(host,
+httpInternal <- function(protocol,
+                         host,
+                         port,
                          method,
                          path,
                          headers,
@@ -88,6 +90,10 @@ httpInternal <- function(host,
   if (!is.null(file) && is.null(contentType))
     stop("You must specify a contentType for the specified file")
 
+  # default port to 80 if necessary
+  if (!nzchar(port))
+    port <- "80"
+
   # read file in binary mode
   if (!is.null(file)) {
     fileLength <- file.info(file)$size
@@ -124,7 +130,7 @@ httpInternal <- function(host,
   # open socket connection
   time <- system.time(gcFirst=FALSE, {
     conn <- socketConnection(host=host,
-                             port=80,
+                             port=as.integer(port),
                              open="w+b",
                              blocking=TRUE)
     on.exit(close(conn))
@@ -148,22 +154,9 @@ httpInternal <- function(host,
   response
 }
 
-httpGetInternal <- function(host,
-                            path,
-                            headers) {
-  httpInternal(host, "GET", path, headers)
-}
-
-httpPostInternal <- function(host,
-                             path,
-                             headers,
-                             contentType,
-                             file) {
-  httpInternal(host, "POST", path, headers, contentType, file)
-}
-
-
-httpCurl <- function(host,
+httpCurl <- function(protocol,
+                     host,
+                     port,
                      method,
                      path,
                      headers,
@@ -202,14 +195,18 @@ httpCurl <- function(host,
                      "--header", paste('"', "Content-Length: ", fileLength, '"', sep=""))
   }
 
+  # add prefix to port if necessary
+  if (nzchar(port))
+    port <- paste(":", port, sep="")
+
   command <- paste(command,
                    extraHeaders,
                    "--header", "Expect:",
                    "--user-agent", userAgent(), 
                    "--silent",
                    "--show-error",
                    "-o", shQuote(outputFile),
-                   paste("https://", host, path, sep=""))
+                   paste(protocol, "://", host, port, path, sep=""))
 
   result <- NULL
   time <- system.time(gcFirst = FALSE, {  
@@ -226,21 +223,9 @@ httpCurl <- function(host,
   }
 }
 
-httpGetCurl <- function(host,
-                        path,
-                        headers) {
-  httpCurl(host, "GET", path, headers)
-}
-
-httpPostCurl <- function(host,
-                         path,
-                         headers,
-                         contentType,
-                         file) {  
-  httpCurl(host, "POST", path, headers, contentType, file)
-}
-
-httpRCurl <- function(host,
+httpRCurl <- function(protocol,
+                      host,
+                      port,
                       method,
                       path,
                       headers,
@@ -250,8 +235,12 @@ httpRCurl <- function(host,
   if (!is.null(file) && is.null(contentType))
     stop("You must specify a contentType for the specified file")
 
+  # add prefix to port if necessary
+  if (nzchar(port))
+    port <- paste(":", port, sep="")
+
   # build url
-  url <- paste("https://", host, path, sep="")
+  url <- paste(protocol, "://", host, port, path, sep="")
 
   # read file in binary mode
   if (!is.null(file)) {
@@ -310,21 +299,6 @@ httpRCurl <- function(host,
        content = textGatherer$value())
 }
 
-
-httpGetRCurl <- function(host,
-                         path,
-                         headers) {
-  httpRCurl(host, "GET", path, headers)
-}
-
-httpPostRCurl <- function(host,
-                          path,
-                          headers,
-                          contentType,
-                          file) {  
-  httpRCurl(host, "POST", path, headers, contentType, file)
-}
-
 httpVerbose <- function() {
   getOption("shinyapps.http.verbose", FALSE)
 }
@@ -398,6 +372,12 @@ httpWithBody <- function(authInfo,
   if ((!is.null(file) && !is.null(content))) 
     stop("You must specify either the file or content parameter but not both.")
 
+  # get the service url
+  service <- serviceUrl()
+
+  # prepend the service path
+  path <- paste(service$path, path, sep="")
+
   # get signature headers and append them
   sigHeaders <- signatureHeaders(authInfo, "POST", path, file)
   headers <- append(headers, sigHeaders)
@@ -410,20 +390,38 @@ httpWithBody <- function(authInfo,
 
   # perform POST
   http <- httpFunction()
-  http("api.shinyapps.io", method, path, headers, contentType, file)
+  http(service$protocol,
+       service$host,
+       service$port,
+       method, 
+       path,
+       headers, 
+       contentType, 
+       file)
 }
 
 GET <- function(authInfo,
                 path, 
                 headers = list()) {
 
+  # get the service url
+  service <- serviceUrl()
+
+  # prepend the service path
+  path <- paste(service$path, path, sep="")
+
   # get signature headers and append them
   sigHeaders <- signatureHeaders(authInfo, "GET", path, NULL)
   headers <- append(headers, sigHeaders)
 
   # perform GET
   http <- httpFunction()
-  http("api.shinyapps.io", "GET", path, headers)
+  http(service$protocol,
+       service$host,
+       service$port,
+       "GET", 
+       path,
+       headers)
 }
 
 signatureHeaders <- function(authInfo, method, path, file) {

R/lucid.R

@@ -9,16 +9,16 @@ lucidClient <- function(authInfo) {
     },
 
     currentUser = function() {
-      handleResponse(GET(authInfo, "/v1/users/current"))
+      handleResponse(GET(authInfo, "/users/current"))
     },
 
     accountsForUser = function(userId) {
-      path <- paste("/v1/users/", userId, "/accounts", sep="")
+      path <- paste("/users/", userId, "/accounts", sep="")
       listRequest(authInfo, path, "accounts")
     },
 
     applications = function(accountId) {
-      path <- paste("/v1/accounts/", accountId, "/applications", sep="")
+      path <- paste("/accounts/", accountId, "/applications", sep="")
       listRequest(authInfo, path, "applications")
     },
 
@@ -27,36 +27,36 @@ lucidClient <- function(authInfo) {
       json$name <- name
       json$template <- template
       json$account <- as.numeric(accountId)
-      handleResponse(POST_JSON(authInfo, "/v1/applications/", json))      
+      handleResponse(POST_JSON(authInfo, "/applications/", json))      
     },
 
     uploadApplication = function(applicationId, bundlePath) {
-      path <- paste("/v1/applications/", applicationId, "/upload", sep="")
+      path <- paste("/applications/", applicationId, "/upload", sep="")
       handleResponse(POST(authInfo, path, "application/x-gzip", bundlePath))
     },
 
     deployApplication = function(applicationId, bundleId) {
-      path <- paste("/v1/applications/", applicationId, "/deploy", sep="")
+      path <- paste("/applications/", applicationId, "/deploy", sep="")
       json <- list()
       json$bundle <- as.numeric(bundleId)
       handleResponse(POST_JSON(authInfo, path, json))
     },
 
     terminateApplication = function(applicationId) {
-      path <- paste("/v1/applications/", applicationId, "/terminate", sep="")
+      path <- paste("/applications/", applicationId, "/terminate", sep="")
       handleResponse(POST_JSON(authInfo, path, list()))
     },
 
     scaleApplication = function(applicationId, instances) {
-      path <- paste("/v1/applications/", applicationId, "/scale", sep="")
+      path <- paste("/applications/", applicationId, "/scale", sep="")
       json <- list()
       json$instance_count <- instances
       handleResponse(POST_JSON(authInfo, path, json))
     },
 
     waitForTaskCompletion = function(taskId, quiet = FALSE) {    
 
-      path <- paste("/v1/tasks/", taskId, sep="")
+      path <- paste("/tasks/", taskId, sep="")
 
       lastStatus <- NULL
       while(TRUE) {