enforce that the target server is shinyapps.io

addAuthorizedUser removeAuthorizedUser showUsers showInvited resendInvitation configureApp setProperty unsetProperty purgeApp restartApp terminateApp showUsage showMetrics Fixes #863 Fixes #864
rstudio · Jun 22, 2023 · 1ce8388 · 1ce8388
1 parent f2e73f0
commit 1ce8388
Show file tree

Hide file tree

Showing 10 changed files with 75 additions and 23 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -194,6 +194,12 @@
 * `accountInfo()` and `removeAccount()` no longer require `account` be 
   supplied (#666).
 
+* Functions that should only interact with shinyapps.io enforce the server
+  type. Updated `addAuthorizedUser()`, `removeAuthorizedUser()`,
+  `showUsers()`, `showInvited()`, `resendInvitation()`, `configureApp()`,
+  `setProperty()`, `unsetProperty()`, `purgeApp()`, `restartApp()`,
+  `terminateApp()`, `showUsage()`, and `showMetrics()` (#863, #864).
+
 * When needed packages are not installed, and you're in an interactive
   environment, rsconnect will now prompt you to install them (#665).
 

diff --git a/R/applications.R b/R/applications.R
@@ -149,16 +149,15 @@ stopWithApplicationNotFound <- function(appName) {
              sep = ""), call. = FALSE)
 }
 
-applicationTask <- function(taskDef, appName, account, server, quiet) {
+applicationTask <- function(taskDef, appName, accountDetails, quiet) {
 
+  # resolve target account and application
+  application <- resolveApplication(accountDetails, appName)
+
   # get status function and display initial status
   displayStatus <- displayStatus(quiet)
   displayStatus(paste(taskDef$beginStatus, "...\n", sep = ""))
 
-  # resolve target account and application
-  accountDetails <- accountInfo(account, server)
-  application <- resolveApplication(accountDetails, appName)
-
   # perform the action
   client <- clientForAccount(accountDetails)
   task <- taskDef$action(client, application)

diff --git a/R/auth.R b/R/auth.R
@@ -48,6 +48,7 @@ addAuthorizedUser <- function(email, appDir = getwd(), appName = NULL,
                               emailMessage = NULL) {
 
   accountDetails <- accountInfo(account, server)
+  checkShinyappsServer(accountDetails$server)
 
   # resolve application
   if (is.null(appName))
@@ -81,6 +82,7 @@ removeAuthorizedUser <- function(user, appDir = getwd(), appName = NULL,
                                  account = NULL, server = NULL) {
 
   accountDetails <- accountInfo(account, server)
+  checkShinyappsServer(accountDetails$server)
 
   # resolve application
   if (is.null(appName))
@@ -131,10 +133,7 @@ showUsers <- function(appDir = getwd(), appName = NULL, account = NULL,
                       server = NULL) {
 
   accountDetails <- accountInfo(account, server)
-
-  if (!isCloudServer(accountDetails$server)) {
-    stop("This method only works for ShinyApps or posit.cloud servers.")
-  }
+  checkShinyappsServer(accountDetails$server)
 
   # resolve application
   if (is.null(appName))
@@ -177,6 +176,7 @@ showInvited <- function(appDir = getwd(), appName = NULL, account = NULL,
                         server = NULL) {
 
   accountDetails <- accountInfo(account, server)
+  checkShinyappsServer(accountDetails$server)
 
   # resolve application
   if (is.null(appName))
@@ -220,6 +220,7 @@ resendInvitation <- function(invite, regenerate = FALSE,
                              account = NULL, server = NULL) {
 
   accountDetails <- accountInfo(account, server)
+  checkShinyappsServer(accountDetails$server)
 
   # get invitations
   invited <- showInvited(appDir, appName, account, server)

diff --git a/R/configureApp.R b/R/configureApp.R
@@ -24,8 +24,9 @@ configureApp <- function(appName, appDir = getwd(), account = NULL, server = NUL
                          redeploy = TRUE, size = NULL,
                          instances = NULL, logLevel = c("normal", "quiet", "verbose")) {
 
-  # resolve target account and application
   accountDetails <- accountInfo(account, server)
+  checkShinyappsServer(accountDetails$server)
+
   application <- resolveApplication(accountDetails, appName)
 
   displayStatus <- displayStatus(identical(logLevel, "quiet"))
@@ -78,8 +79,7 @@ configureApp <- function(appName, appDir = getwd(), account = NULL, server = NUL
 #' @param appName Name of application
 #' @param appPath Directory or file that was deployed. Defaults to current
 #'   working directory.
-#' @param account Account name. If a single account is registered on the system
-#'   then this parameter can be omitted.
+#' @inheritParams deployApp
 #' @param force Forcibly set the property
 #'
 #' @note This function only works for ShinyApps servers.
@@ -96,11 +96,13 @@ configureApp <- function(appName, appDir = getwd(), account = NULL, server = NUL
 #' }
 #' @export
 setProperty <- function(propertyName, propertyValue, appPath = getwd(),
-                        appName = NULL, account = NULL, force = FALSE) {
+                        appName = NULL, account = NULL, server = NULL, force = FALSE) {
 
   # resolve the application target and target account info
-  target <- findDeployment(appPath, appName, account)
-  accountDetails <- accountInfo(target$account)
+  target <- findDeployment(appPath, appName, account, server)
+  accountDetails <- accountInfo(target$account, target$server)
+  checkShinyappsServer(accountDetails$server)
+
   client <- clientForAccount(accountDetails)
   application <- getAppByName(client, accountDetails, target$appName)
   if (is.null(application))
@@ -122,8 +124,7 @@ setProperty <- function(propertyName, propertyValue, appPath = getwd(),
 #' @param appName Name of application
 #' @param appPath Directory or file that was deployed. Defaults to current
 #'   working directory.
-#' @param account Account name. If a single account is registered on the system
-#'   then this parameter can be omitted.
+#' @inheritParams deployApp
 #' @param force Forcibly unset the property
 #'
 #' @note This function only works for ShinyApps servers.
@@ -137,11 +138,13 @@ setProperty <- function(propertyName, propertyValue, appPath = getwd(),
 #' }
 #' @export
 unsetProperty <- function(propertyName, appPath = getwd(), appName = NULL,
-                          account = NULL, force = FALSE) {
+                          account = NULL, server = NULL, force = FALSE) {
 
   # resolve the application target and target account info
-  target <- findDeployment(appPath, appName, account)
-  accountDetails <- accountInfo(target$account)
+  target <- findDeployment(appPath, appName, account, server)
+  accountDetails <- accountInfo(target$account, target$server)
+  checkShinyappsServer(accountDetails$server)
+
   client <- clientForAccount(accountDetails)
   application <- getAppByName(client, accountInfo, target$appName)
   if (is.null(application))

diff --git a/R/purgeApp.R b/R/purgeApp.R
@@ -23,6 +23,8 @@
 #' @export
 purgeApp <- function(appName, account = NULL, server = NULL,
                      quiet = FALSE) {
+  accountDetails <- accountInfo(account, server)
+  checkShinyappsServer(accountDetails$server)
 
   # define purge task
   taskDef <- list()
@@ -33,5 +35,5 @@ purgeApp <- function(appName, account = NULL, server = NULL,
   }
 
   # perform it
-  applicationTask(taskDef, appName, account, server = server, quiet)
+  applicationTask(taskDef, appName, accountDetails, quiet)
 }
diff --git a/R/restartApp.R b/R/restartApp.R
@@ -20,6 +20,8 @@
 #' @note This function works only for ShinyApps servers.
 #' @export
 restartApp <- function(appName, account = NULL, server = NULL, quiet = FALSE) {
+  accountDetails <- accountInfo(account, server)
+  checkShinyappsServer(accountDetails$server)
 
   # define deploy task
   taskDef <- list()
@@ -30,5 +32,5 @@ restartApp <- function(appName, account = NULL, server = NULL, quiet = FALSE) {
   }
 
   # perform it
-  applicationTask(taskDef, appName, account, server, quiet)
+  applicationTask(taskDef, appName, accountDetails, quiet)
 }
diff --git a/R/servers.R b/R/servers.R
@@ -64,10 +64,22 @@ isCloudServer <- function(server) {
   server %in% cloudServers
 }
 
+checkCloudServer <- function(server, call = caller_env()) {
+  if (!isCloudServer(server)) {
+    cli::cli_abort("`server` must be shinyapps.io or posit.cloud", call = call)
+  }
+}
+
 isShinyappsServer <- function(server) {
   identical(server, "shinyapps.io")
 }
 
+checkShinyappsServer <- function(server, call = caller_env()) {
+  if (!isShinyappsServer(server)) {
+    cli::cli_abort("`server` must be shinyapps.io", call = call)
+  }
+}
+
 isRPubs <- function(server) {
   identical(server, "rpubs.com")
 }

diff --git a/R/terminateApp.R b/R/terminateApp.R
@@ -23,6 +23,8 @@
 #' @export
 terminateApp <- function(appName, account = NULL, server = NULL,
                          quiet = FALSE) {
+  accountDetails <- accountInfo(account, server)
+  checkShinyappsServer(accountDetails$server)
 
   # define terminate task
   taskDef <- list()
@@ -33,5 +35,5 @@ terminateApp <- function(appName, account = NULL, server = NULL,
   }
 
   # perform it
-  applicationTask(taskDef, appName, account, server = server, quiet)
+  applicationTask(taskDef, appName, accountDetails, quiet)
 }
diff --git a/R/usage.R b/R/usage.R
@@ -18,6 +18,8 @@ showUsage <- function(appDir = getwd(), appName = NULL, account = NULL, server =
                       usageType = "hours", from = NULL, until = NULL, interval = NULL) {
 
   accountDetails <- accountInfo(account, server)
+  checkShinyappsServer(accountDetails$server)
+
   api <- clientForAccount(accountDetails)
 
   # resolve application
@@ -121,6 +123,8 @@ showMetrics <- function(metricSeries,
 accountUsage <- function(account = NULL, server = NULL, usageType = "hours",
                          from = NULL, until = NULL, interval = NULL) {
   accountDetails <- accountInfo(account, server)
+  checkShinyappsServer(accountDetails$server)
+
   api <- clientForAccount(accountDetails)
 
   # get application usage

diff --git a/tests/testthat/test-servers.R b/tests/testthat/test-servers.R
@@ -126,6 +126,27 @@ test_that("All hosted product names are identified as cloud", {
   expect_false(isCloudServer("connect.internal"))
 })
 
+test_that("All hosted product names are identified as cloud", {
+  checkCloudServer("shinyapps.io")
+  checkCloudServer("rstudio.cloud")
+  checkCloudServer("posit.cloud")
+  expect_error(checkCloudServer("connect.internal"))
+})
+
+test_that("only shinyapps.io is identified as shinyapps.io", {
+  expect_true(isShinyappsServer("shinyapps.io"))
+  expect_false(isShinyappsServer("rstudio.cloud"))
+  expect_false(isShinyappsServer("posit.cloud"))
+  expect_false(isShinyappsServer("connect.internal"))
+})
+
+test_that("only shinyapps.io is identified as shinyapps.io", {
+  checkShinyappsServer("shinyapps.io")
+  expect_error(checkShinyappsServer("rstudio.cloud"))
+  expect_error(checkShinyappsServer("posit.cloud"))
+  expect_error(checkShinyappsServer("connect.internal"))
+})
+
 test_that("predefined servers includes cloud and shinyapps", {
   local_temp_config()