-
Notifications
You must be signed in to change notification settings - Fork 32
/
cred_funs.R
237 lines (217 loc) · 6.97 KB
/
cred_funs.R
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
#' Credential function registry
#'
#' Functions to query or manipulate the registry of credential functions
#' consulted by [token_fetch()].
#'
#' @name cred_funs
#'
#' @seealso [token_fetch()], which is where the registry is actually used.
#' @return A list of credential functions or `NULL`.
#' @examples
#' names(cred_funs_list())
#'
#' creds_one <- function(scopes, ...) {}
#'
#' cred_funs_add(one = creds_one)
#' cred_funs_add(two = creds_one, three = creds_one)
#' names(cred_funs_list())
#'
#' cred_funs_add(two = NULL)
#' names(cred_funs_list())
#'
#' # restore the default list
#' cred_funs_set_default()
#'
#' # remove one specific credential fetcher
#' cred_funs_add(credentials_gce = NULL)
#' names(cred_funs_list())
#'
#' # force the use of one specific credential fetcher
#' cred_funs_set(list(credentials_user_oauth2 = credentials_user_oauth2))
#' names(cred_funs_list())
#'
#' # restore the default list
#' cred_funs_set_default()
#'
#' # run some code with a temporary change to the registry
#' # creds_one ONLY
#' with_cred_funs(
#' list(one = creds_one),
#' names(cred_funs_list())
#' )
#' # add creds_one to the list
#' with_cred_funs(
#' list(one = creds_one),
#' names(cred_funs_list()),
#' action = "modify"
#' )
#' # remove credentials_gce
#' with_cred_funs(
#' list(credentials_gce = NULL),
#' names(cred_funs_list()),
#' action = "modify"
#' )
NULL
#' @describeIn cred_funs Get the list of registered credential functions.
#' @export
cred_funs_list <- function() {
gargle_env$cred_funs
}
#' @describeIn cred_funs Register one or more new credential fetching functions.
#' Function(s) are added to the *front* of the list. So:
#' * "First registered, last tried."
#' * "Last registered, first tried."
#'
#' Can also be used to *remove* a function from the registry.
#'
#' @param ... <[`dynamic-dots`][rlang::dyn-dots]> One or more credential
#' functions, in `name = value` form. Each credential function is subject to a
#' superficial check that it at least "smells like" a credential function: its
#' first argument must be named `scopes`, and its signature must include
#' `...`. To remove a credential function, you can use a specification like
#' `name = NULL`.
#' @export
cred_funs_add <- function(...) {
dots <- dots_list(
...,
.named = NULL,
.ignore_empty = "all",
.preserve_empty = FALSE,
.homonyms = "error",
.check_assign = TRUE
)
cred_funs_check(dots, allow_null = TRUE)
nms_to_remove <- names(dots)[map_lgl(dots, is.null)]
cf <- cred_funs_list()
cf[nms_to_remove] <- NULL
cred_funs_set(cf)
dots <- dots[!map_lgl(dots, is.null)]
dup_nm <- names(dots) %in% names(cred_funs_list())
if (any(dup_nm)) {
n_dup_nm <- sum(dup_nm)
gargle_abort(c(
"{cli::qty(n_dup_nm)}{?This/These} name{?s} already {?appears/appear} \\
in the credential function registry:",
x = "{.field {names(dots)[dup_nm]}}"
))
}
# add them in reverse order, to mimic what would happen if they'd been added
# one-at-a-time
cf <- cred_funs_list()
cred_funs_set(c(rev(dots), cf))
invisible(cred_funs_list())
}
#' @describeIn cred_funs Register a list of credential fetching functions.
#'
#' @param funs A named list of credential functions.
#' @param ls `r lifecycle::badge("deprecated")` This argument has been renamed
#' to `funs`.
#' @export
cred_funs_set <- function(funs, ls = deprecated()) {
if (lifecycle::is_present(ls)) {
lifecycle::deprecate_warn(
when = "1.3.0",
what = "cred_funs_set(ls)",
with = "cred_funs_set(funs)",
)
funs = ls
}
cred_funs_check(funs, allow_null = FALSE)
gargle_env$cred_funs <- funs
invisible(cred_funs_list())
}
#' @describeIn cred_funs Clear the credential function registry.
#' @export
cred_funs_clear <- function() {
gargle_env$cred_funs <- list()
invisible(cred_funs_list())
}
#' @describeIn cred_funs Return the default list of credential functions.
#' @export
cred_funs_list_default <- function() {
list(
credentials_byo_oauth2 = credentials_byo_oauth2,
credentials_service_account = credentials_service_account,
credentials_external_account = credentials_external_account,
credentials_app_default = credentials_app_default,
credentials_gce = credentials_gce,
credentials_user_oauth2 = credentials_user_oauth2
)
}
#' @describeIn cred_funs Reset the registry to the gargle default.
#' @export
cred_funs_set_default <- function() {
cred_funs_set(cred_funs_list_default())
}
#' @describeIn cred_funs Modify the credential function registry in the current
#' scope. It is an example of the `local_*()` functions in \pkg{withr}.
#' @param action Whether to use `funs` to replace or modify the registry with
#' funs:
#' * `"replace"` does `cred_funs_set(funs)`
#' * `"modify"` does `cred_funs_add(!!!funs)`
#' @param .local_envir The environment to use for scoping. Defaults to current
#' execution environment.
#' @export
local_cred_funs <- function(funs = cred_funs_list_default(),
action = c("replace", "modify"),
.local_envir = caller_env()) {
action <- arg_match(action)
cred_funs_orig <- cred_funs_list()
withr::defer(cred_funs_set(cred_funs_orig), envir = .local_envir)
switch(
action,
replace = cred_funs_set(funs),
modify = cred_funs_add(!!!funs)
)
}
#' @describeIn cred_funs Evaluate `code` with a temporarily modified credential
#' function registry. It is an example of the `with_*()` functions in
#' \pkg{withr}.
#' @param code Code to run with temporary credential function registry.
#' @export
with_cred_funs <- function(funs = cred_funs_list_default(),
code,
action = c("replace", "modify")) {
local_cred_funs(funs = funs, action = action)
force(code)
}
cred_funs_check <- function(ls, allow_null = FALSE) {
if (allow_null) {
not_cred_fun <- !map_lgl(ls, is.null) & !map_lgl(ls, is_cred_fun)
} else {
not_cred_fun <- !map_lgl(ls, is_cred_fun)
}
if (any(not_cred_fun)) {
gargle_abort(c(
"Not a valid credential function:",
x = "Element{?s} {as.character(which(not_cred_fun))}"
))
}
if (!is_dictionaryish(ls)) {
gargle_abort("Each credential function must have a unique name")
}
invisible()
}
#' Check that f is a viable credential fetching function
#'
#' In the abstract, a credential fetching function is any function which takes a
#' set of scopes and any number of additional arguments, and returns either a
#' valid [`httr::Token`][httr::Token-class] or `NULL`.
#'
#' Here we say that a function is valid if its first argument is named `scopes`,
#' and it includes `...` as an argument, since it's difficult to actually check
#' the behavior of the function.
#'
#' @param f A function to check.
#' @keywords internal
#' @noRd
#' @examples
#' f <- function(scopes, ...) {}
#' is_cred_fun(f)
is_cred_fun <- function(f) {
if (!is.function(f)) {
return(FALSE)
}
args <- names(formals(f))
args[1] == "scopes" && "..." %in% args
}