R/client-cloud.R

In rsconnect: Deploy Docs, Apps, and APIs to 'Posit Connect', 'shinyapps.io', and 'RPubs'

# Docs: https://build.posit.it/job/hostedapps/job/lucid-pipeline/job/main/API/

getCurrentProjectId <- function(service, authInfo) {
  currentApplicationId <- Sys.getenv("LUCID_APPLICATION_ID")
  if (currentApplicationId != "") {
    path <- paste0("/applications/", currentApplicationId)
    current_application <- GET(service, authInfo, path)
    return(current_application$content_id)
  }
}

cloudClient <- function(service, authInfo) {
  list(
    status = function() {
      GET(service, authInfo, "/internal/status")
    },

    service = function() {
      "posit.cloud"
    },

    currentUser = function() {
      GET(service, authInfo, "/users/current/")
    },

    accountsForUser = function(userId) {
      path <- "/accounts/"
      query <- ""
      listRequest(service, authInfo, path, query, "accounts")
    },

    getAccountUsage = function(
      accountId,
      usageType = "hours",
      applicationId = NULL,
      from = NULL,
      until = NULL,
      interval = NULL
    ) {
      path <- paste0("/accounts/", accountId, "/usage/", usageType, "/")
      query <- list()
      if (!is.null(applicationId)) {
        query$application <- applicationId
      }
      if (!is.null(from)) {
        query$from <- from
      }
      if (!is.null(until)) {
        query$until <- until
      }
      if (!is.null(interval)) {
        query$interval <- interval
      }
      GET(service, authInfo, path, queryString(query))
    },

    getBundle = function(bundleId) {
      path <- paste0("/bundles/", bundleId)
      GET(service, authInfo, path)
    },

    updateBundleStatus = function(bundleId, status) {
      path <- paste0("/bundles/", bundleId, "/status")
      json <- list()
      json$status <- status
      POST_JSON(service, authInfo, path, json)
    },

    createBundle = function(
      application,
      content_type,
      content_length,
      checksum
    ) {
      json <- list()
      json$application <- application
      json$content_type <- content_type
      json$content_length <- content_length
      json$checksum <- checksum
      POST_JSON(service, authInfo, "/bundles", json)
    },

    listApplications = function(accountId, filters = list()) {
      path <- "/applications/"
      query <- paste(
        filterQuery(
          c("account_id", "type", names(filters)),
          c(accountId, "connect", unname(filters))
        ),
        collapse = "&"
      )
      listRequest(service, authInfo, path, query, "applications")
    },

    getApplication = function(outputOrApplicationId, deploymentRecordVersion) {
      # The IDE doesn't know whether the id is for a content or an application, so we
      # support both.
      if (is.na(deploymentRecordVersion)) {
        # In pre-versioned dcf files, outputOrApplicationId is the id of the application.
        # TODO: consider removing support for this case a year after the release of 1.0.0
        path <- paste0("/applications/", outputOrApplicationId)
        application <- GET(service, authInfo, path)

        output_id <- application$output_id %||% application$content_id

        path <- paste0("/outputs/", output_id)
        output <- GET(service, authInfo, path)
      } else if (deploymentRecordVersion == "unknown") {
        handleError <- function(err) {
          path <- paste0("/applications/", outputOrApplicationId)
          application <- GET(service, authInfo, path)

          output_id <- application$output_id %||% application$content_id

          path <- paste0("/outputs/", output_id)
          output <- GET(service, authInfo, path)

          list(application = application, output = output)
        }
        applicationAndOutput <- tryCatch(
          {
            path <- paste0("/outputs/", outputOrApplicationId)
            output <- GET(service, authInfo, path)

            path <- paste0("/applications/", output$source_id)
            application <- GET(service, authInfo, path)

            list(application = application, output = output)
          },
          rsconnect_http_403 = handleError,
          rsconnect_http_404 = handleError
        )
        application <- applicationAndOutput$application
        output <- applicationAndOutput$output
      } else {
        # from dcf version >= 1, outputOrApplicationId is the id of the output.
        path <- paste0("/outputs/", outputOrApplicationId)
        output <- GET(service, authInfo, path)

        path <- paste0("/applications/", output$source_id)
        application <- GET(service, authInfo, path)
        application
      }

      # if the output is trashed or archived, restore it to the active state
      if (output$state == "trashed" || output$state == "archived") {
        json <- list()
        json$state <- "active"
        PATCH_JSON(service, authInfo, paste0("/outputs/", output$id), json)
      }

      # Each redeployment of a static output creates a new application. Since
      # those applications can be deleted, it's more reliable to reference
      # outputs by their own id instead of the applications'.
      application$application_id <- application$id
      application$id <- output$id
      application$url <- output$url
      application$name <- output$name
      application
    },

    getApplicationMetrics = function(
      applicationId,
      series,
      metrics,
      from = NULL,
      until = NULL,
      interval = NULL
    ) {
      path <- paste0("/applications/", applicationId, "/metrics/", series, "/")
      query <- list()
      m <- paste(
        lapply(metrics, function(x) {
          paste("metric", urlEncode(x), sep = "=")
        }),
        collapse = "&"
      )
      if (!is.null(from)) {
        query$from <- from
      }
      if (!is.null(until)) {
        query$until <- until
      }
      if (!is.null(interval)) {
        query$interval <- interval
      }
      GET(service, authInfo, path, paste(m, queryString(query), sep = "&"))
    },

    getLogs = function(applicationId, entries = 50) {
      path <- paste0("/applications/", applicationId, "/logs")
      query <- paste0("count=", entries, "&tail=0")
      GET(service, authInfo, path, query)
    },

    createApplication = function(
      name,
      title,
      template,
      accountId,
      appMode,
      contentCategory = NULL,
      spaceId = NULL
    ) {
      json <- list()
      json$name <- name
      json$application_type <- if (
        appMode %in% c("rmd-static", "quarto-static", "static")
      ) {
        "static"
      } else {
        "connect"
      }
      if (appMode %in% c("rmd-static", "quarto-static")) {
        json$render_by <- "server"
      }

      currentProjectId <- getCurrentProjectId(service, authInfo)
      # in case the source cloud project is a temporary copy, there is no
      # content id. The output will be published without a space id.
      if (!is.null(currentProjectId)) {
        json$project <- currentProjectId

        path <- paste0("/content/", currentProjectId)
        currentProject <- GET(service, authInfo, path)
        json$space <- currentProject$space_id
      }

      json$content_category <- contentCategory

      if (is.null(currentProjectId) && !is.null(spaceId)) {
        json$space <- spaceId
      }

      output <- POST_JSON(service, authInfo, "/outputs", json)
      path <- paste0("/applications/", output$source_id)
      application <- GET(service, authInfo, path)
      list(
        id = output$id,
        application_id = application$id,
        url = output$url
      )
    },

    listApplicationProperties = function(applicationId) {
      path <- paste0("/applications/", applicationId, "/properties/")
      GET(service, authInfo, path)
    },

    setApplicationProperty = function(
      applicationId,
      propertyName,
      propertyValue,
      force = FALSE
    ) {
      path <- paste0(
        "/applications/",
        applicationId,
        "/properties/",
        propertyName
      )
      v <- list()
      v$value <- propertyValue
      query <- paste0("force=", if (force) "1" else "0")
      PUT_JSON(service, authInfo, path, v, query)
    },

    unsetApplicationProperty = function(
      applicationId,
      propertyName,
      force = FALSE
    ) {
      path <- paste0(
        "/applications/",
        applicationId,
        "/properties/",
        propertyName
      )
      query <- paste0("force=", if (force) "1" else "0")
      DELETE(service, authInfo, path, query)
    },

    uploadApplication = function(applicationId, bundlePath) {
      path <- paste0("/applications/", applicationId, "/upload")
      POST(
        service,
        authInfo,
        path,
        contentType = "application/x-gzip",
        file = bundlePath
      )
    },

    createRevision = function(application, contentCategory) {
      path <- paste0("/outputs/", application$id, "/revisions")
      json <- list(content_category = contentCategory)
      revision <- POST_JSON(service, authInfo, path, json)
      revision$application_id
    },

    deployApplication = function(application, bundleId = NULL, spaceId = NULL) {
      currentProjectId <- getCurrentProjectId(service, authInfo)
      if (!is.null(currentProjectId)) {
        PATCH_JSON(
          service,
          authInfo,
          paste0("/outputs/", application$id),
          list(project = currentProjectId)
        )
      }

      if (!is.null(spaceId)) {
        PATCH_JSON(
          service,
          authInfo,
          paste0("/outputs/", application$id),
          list(space = spaceId)
        )
      }

      path <- paste0("/applications/", application$application_id, "/deploy")
      json <- list()
      if (length(bundleId) > 0 && nzchar(bundleId)) {
        json$bundle <- as.numeric(bundleId)
      } else {
        json$rebuild <- FALSE
      }
      POST_JSON(service, authInfo, path, json)
    },

    terminateApplication = function(applicationId) {
      path <- paste0("/applications/", applicationId, "/terminate")
      POST(service, authInfo, path)
    },

    purgeApplication = function(applicationId) {
      path <- paste0("/applications/", applicationId, "/purge")
      POST(service, authInfo, path)
    },

    inviteApplicationUser = function(
      applicationId,
      email,
      invite_email = NULL,
      invite_email_message = NULL
    ) {
      path <- paste0("/applications/", applicationId, "/authorization/users")
      json <- list()
      json$email <- email
      if (!is.null(invite_email)) {
        json$invite_email <- invite_email
      }
      if (!is.null(invite_email_message)) {
        json$invite_email_message <- invite_email_message
      }
      POST_JSON(service, authInfo, path, json)
    },

    addApplicationUser = function(applicationId, userId) {
      path <- paste0(
        "/applications/",
        applicationId,
        "/authorization/users/",
        userId
      )
      PUT(service, authInfo, path, NULL)
    },

    removeApplicationUser = function(applicationId, userId) {
      path <- paste0(
        "/applications/",
        applicationId,
        "/authorization/users/",
        userId
      )
      DELETE(service, authInfo, path)
    },

    listApplicationAuthorization = function(applicationId) {
      path <- paste0("/applications/", applicationId, "/authorization")
      listRequest(service, authInfo, path, NULL, "authorization")
    },

    listApplicationUsers = function(applicationId) {
      path <- paste0("/applications/", applicationId, "/authorization/users")
      listRequest(service, authInfo, path, NULL, "users")
    },

    listApplicationGroups = function(applicationId) {
      path <- paste0("/applications/", applicationId, "/authorization/groups")
      listRequest(service, authInfo, path, NULL, "groups")
    },

    listApplicationInvitations = function(applicationId) {
      path <- "/invitations/"
      query <- paste(filterQuery("app_id", applicationId), collapse = "&")
      listRequest(service, authInfo, path, query, "invitations")
    },

    listTasks = function(accountId, filters = NULL) {
      if (is.null(filters)) {
        filters <- vector()
      }
      path <- "/tasks/"
      filters <- c(filterQuery("account_id", accountId), filters)
      query <- paste(filters, collapse = "&")
      listRequest(service, authInfo, path, query, "tasks", max = 100)
    },

    getTaskInfo = function(taskId) {
      path <- paste0("/tasks/", taskId)
      GET(service, authInfo, path)
    },

    getTaskLogs = function(taskId) {
      path <- paste0("/tasks/", taskId, "/logs/")
      GET(service, authInfo, path)
    },

    waitForTask = function(taskId, quiet = FALSE) {
      if (!quiet) {
        cat("Waiting for task: ", taskId, "\n", sep = "")
      }

      path <- paste0("/tasks/", taskId)

      lastStatus <- NULL
      while (TRUE) {
        # check status
        status <- GET(service, authInfo, path)

        # display status to the user if it changed
        if (!identical(lastStatus, status$description)) {
          if (!quiet) {
            cat("  ", status$status, ": ", status$description, "\n", sep = "")
          }
          lastStatus <- status$description
        }

        # are we finished? (note: this codepath is the only way to exit this function)
        if (status$finished) {
          if (identical(status$status, "success")) {
            return(NULL)
          } else {
            # always show task log on error
            cli::cat_rule("Begin Task Log", line = "#")
            taskLog(taskId, authInfo$name, authInfo$server, output = "stderr")
            cli::cat_rule("End Task Log", line = "#")
            stop(status$error, call. = FALSE)
          }
        }

        # wait for 1 second before polling again
        Sys.sleep(1)
      }
    }
  )
}