File: deployments.R

package info (click to toggle)
r-cran-rsconnect 1.3.4-1
  • links: PTS, VCS
  • area: main
  • in suites: forky, sid, trixie
  • size: 2,044 kB
  • sloc: python: 185; sh: 13; makefile: 5
file content (252 lines) | stat: -rw-r--r-- 9,144 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
#' List Application Deployments
#'
#' List deployment records for a given application.
#' @param appPath The path to the content that was deployed, either a directory
#'   or an individual document.
#' @param nameFilter Return only deployments matching the given name (optional)
#' @param accountFilter Return only deployments matching the given account
#'   (optional)
#' @param serverFilter Return only deployments matching the given server
#'   (optional)
#' @param excludeOrphaned If `TRUE` (the default), return only deployments
#'   made by a currently registered account. Deployments made from accounts that
#'   are no longer registered (via e.g.[removeAccount()]) will not be
#'   returned.
#' @return
#' Returns a data frame with at least following columns:
#' \tabular{ll}{
#' `name` \tab Name of deployed application\cr
#' `account` \tab Account owning deployed application\cr
#' `bundleId` \tab Identifier of deployed application's bundle\cr
#' `url` \tab URL of deployed application\cr
#' `deploymentFile` \tab Name of configuration file\cr
#' }
#'
#' If additional metadata has been saved with the deployment record using the
#' `metadata` argument to [deployApp()], the frame will include
#' additional columns.
#'
#' @examples
#' \dontrun{
#'
#' # Return all deployments of the ~/r/myapp directory made with the 'abc'
#' # account
#' deployments("~/r/myapp", accountFilter="abc")
#' }
#' @seealso [applications()] to get a list of deployments from the
#'   server, and [deployApp()] to create a new deployment.
#' @export
deployments <- function(appPath = ".",
                        nameFilter = NULL,
                        accountFilter = NULL,
                        serverFilter = NULL,
                        excludeOrphaned = TRUE) {

  migrateDeploymentsConfig(appPath)
  paths <- deploymentConfigFiles(appPath)

  dcf <- lapply(paths, read.dcf)
  dcf <- lapply(dcf, as.data.frame, stringsAsFactors = FALSE)

  deployments <- rbind_fill(dcf, deploymentFields)
  deployments$deploymentFile <- paths

  # Apply filters
  ok <- rep(TRUE, nrow(deployments))
  if (!is.null(nameFilter)) {
    ok <- ok & deployments$name == nameFilter
  }
  if (!is.null(accountFilter)) {
    ok <- ok & deployments$account == accountFilter
  }
  if (!is.null(serverFilter)) {
    ok <- ok & deployments$server == serverFilter
  }
  if (excludeOrphaned) {
    activeAccounts <- accounts()
    activeAccountServers <- paste0(activeAccounts$server, "@", activeAccounts$name)
    accountServer <- paste0(deployments$server, "@", deployments$account)
    okServer <- isRPubs(deployments$server) | accountServer %in% activeAccountServers
    ok <- ok & okServer
  }

  deployments$envVars[is.na(deployments$envVars)] <- ""
  if (is.character(deployments$envVars)) {
    deployments$envVars <- strsplit(deployments$envVars, ", ")
  }

  deployments[ok, , drop = FALSE]
}

deploymentFields <- c(
  "name", "title", "username", "account", "server", "hostUrl", "appId",
  "bundleId", "url", "envVars", "version"
)

deploymentRecordVersion <- 1L

# Save a deployment record to disk using an incoming record (which may or may
# not correspond to an existing on-disk deployment record). Created by
# deploymentRecord() or by findDeploymentTarget(), and possibly loaded from
# disk.
saveDeployment <- function(recordDir,
                           deployment,
                           application,
                           bundleId = NULL,
                           hostUrl = serverInfo(deployment$server)$url,
                           metadata = list(),
                           addToHistory = TRUE) {
  deployment <- deploymentRecord(
    name = deployment$name,
    title = deployment$title,
    username = deployment$username,
    account = deployment$account,
    server = deployment$server,
    envVars = deployment$envVars,
    version = deployment$version,
    hostUrl = hostUrl,
    appId = application$id,
    bundleId = bundleId,
    url = application$url,
    metadata = metadata
  )
  path <- deploymentConfigFile(recordDir, deployment$name, deployment$account, deployment$server)
  writeDeploymentRecord(deployment, path)

  # also save to global history
  if (addToHistory) {
    addToDeploymentHistory(recordDir, deployment)
  }

  invisible(path)
}

deploymentRecord <- function(name,
                             title,
                             username,
                             account,
                             server,
                             envVars = NULL,
                             hostUrl = NULL,
                             appId = NULL,
                             bundleId = NULL,
                             url = NULL,
                             version = deploymentRecordVersion,
                             metadata = list()) {

  check_character(envVars, allow_null = TRUE)

  standard <- list(
    name = name,
    title = title %||% "",
    username = username,
    account = account,
    server = server,
    envVars = if (length(envVars) > 0) paste0(envVars, collapse = ", ") else NA,
    hostUrl = hostUrl %||% "",
    appId = appId %||% "",
    bundleId = bundleId %||% "",
    url = url %||% "",
    version = version
  )
  # convert any multi-value metadata entries into comma-separated values
  # this prevents write.dcf from writing multiple records into one file.
  metadata <- lapply(metadata, function(v) paste0(v, collapse = ", "))
  c(standard, metadata)
}

writeDeploymentRecord <- function(record, filePath) {
  # use a long width so URLs don't line-wrap
  write.dcf(record, filePath, width = 4096)
}

# Workbench uses to show a list of recently deployed content on user dashboard
addToDeploymentHistory <- function(appPath, deploymentRecord) {
  # add the appPath to the deploymentRecord
  deploymentRecord$appPath <- appPath

  # write new history file
  newHistory <- deploymentHistoryPath(new = TRUE)
  writeDeploymentRecord(deploymentRecord, newHistory)

  history <- deploymentHistoryPath()
  # append existing history to new history
  if (file.exists(history)) {
    cat("\n", file = newHistory, append = TRUE)
    file.append(newHistory, history)
  }

  # overwrite with new history
  file.rename(newHistory, history)
  invisible()
}

#' Forget Application Deployment
#'
#' Forgets about an application deployment. This is useful if the application
#' has been deleted on the server, or the local deployment information needs to
#' be reset.
#'
#' @param appPath The path to the content that was deployed, either a directory
#'   or an individual document.
#' @param name The name of the content that was deployed (optional)
#' @param account The name of the account to which the content was deployed
#'   (optional)
#' @param server The name of the server to which the content was deployed
#'   (optional)
#' @param dryRun Set to TRUE to preview the files/directories to be removed
#'   instead of actually removing them. Defaults to FALSE.
#' @param force Set to TRUE to remove files and directories without prompting.
#'   Defaults to FALSE in interactive sessions.
#' @return NULL, invisibly.
#'
#' @details This method removes from disk the file containing deployment
#'   metadata. If "name", "account", and "server" are all NULL, then all of the
#'   deployments for the application are forgotten; otherwise, only the
#'   specified deployment is forgotten.
#'
#' @export
forgetDeployment <- function(appPath = getwd(), name = NULL,
                             account = NULL, server = NULL,
                             dryRun = FALSE, force = !interactive()) {
  if (is.null(name) && is.null(account) && is.null(server)) {
    dcfDir <- deploymentConfigDir(appPath)
    if (dryRun)
      message("Would remove the directory ", dcfDir)
    else if (file.exists(dcfDir)) {
      if (!force) {
        prompt <- paste("Forget all deployment records for ", appPath, "? [Y/n] ", sep = "")
        input <- readline(prompt)
        if (nzchar(input) && !identical(input, "y") && !identical(input, "Y"))
          stop("No deployment records removed.", call. = FALSE)
      }
      unlink(dcfDir, recursive = TRUE)
    } else {
      message("No deployments found for the application at ", appPath)
    }
  } else {
    if (is.null(name) || is.null(account) || is.null(server)) {
      stop("Invalid argument. ",
           "Supply the name, account, and server of the deployment record to delete. ",
           "Supply NULL for all three to delete all deployment records.")
    }
    dcf <- deploymentConfigFile(appPath, name, account, server)
    if (dryRun)
      message("Would remove the file ", dcf)
    else if (file.exists(dcf)) {
      if (!force) {
        prompt <- paste("Forget deployment of ", appPath, " to '", name, "' on ",
                        server, "? [Y/n] ", sep = "")
        input <- readline(prompt)
        if (nzchar(input) && !identical(input, "y") && !identical(input, "Y"))
          stop("Cancelled. No deployment records removed.", call. = FALSE)
      }
      unlink(dcf)
    } else {
      message("No deployment of ", appPath, " to '", name, "' on ", server,
              " found.")
    }
  }

  invisible(NULL)
}