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
|
#' Remove or replace query parameters
#' @noRd
query_params_remove <- function(int) {
h <- vcr_c$filter_query_parameters
if (!is.null(h)) {
if (is.null(names(h))) toremove <- unlist(h)
if (!is.null(names(h))) toremove <- unname(unlist(h[!nzchar(names(h))]))
# remove zero length strings
toremove <- Filter(nzchar, toremove)
for (i in seq_along(toremove)) {
int <- lapply(int, function(b) {
b$request$uri <- drop_param(b$request$uri, toremove[i])
return(b)
})
}
toreplace <- h[nzchar(names(h))]
if (length(toreplace)) {
for (i in seq_along(toreplace)) {
int <- lapply(int, function(b) {
vals <- toreplace[[i]]
val <- if (length(vals) == 2) vals[2] else vals[1]
b$request$uri <-
replace_param(b$request$uri, names(toreplace)[i], val)
return(b)
})
}
}
}
return(int)
}
#' Put back query parameters
#' @details Ignore character strings as we can't put back completely removed
#' query parameters
#' @noRd
query_params_put_back <- function(int) {
h <- vcr_c$filter_query_parameters
if (!is.null(h)) {
toputback <- h[nzchar(names(h))]
if (length(toputback)) {
for (i in seq_along(toputback)) {
int$http_interactions <- lapply(int$http_interactions, function(b) {
vals <- toputback[[i]]
if (length(vals) == 2) {
b$request$uri <-
replace_param_with(b$request$uri, names(toputback)[i], vals[2], vals[1])
} else {
b$request$uri <-
replace_param(b$request$uri, names(toputback)[i], vals)
}
return(b)
})
}
}
}
return(int)
}
query_params_remove_str <- function(uri) {
h <- vcr_c$filter_query_parameters
if (!is.null(h)) {
if (is.null(names(h))) toremove <- unlist(h)
if (!is.null(names(h))) toremove <- unname(unlist(h[!nzchar(names(h))]))
toremove <- Filter(nzchar, toremove)
for (i in seq_along(toremove)) uri <- drop_param(uri, toremove[i])
toreplace <- h[nzchar(names(h))]
if (length(toreplace)) {
for (i in seq_along(toreplace)) {
vals <- toreplace[[i]]
if (length(vals) == 2) {
uri <-
replace_param_with(uri, names(toreplace)[i], vals[2], vals[1])
} else {
uri <- replace_param(uri, names(toreplace)[i], vals)
}
}
}
}
return(uri)
}
list2str <- function(w) {
paste(names(w), unlist(unname(w)), sep="=", collapse="&")
}
buildurl <- function(x) {
x$parameter <- list2str(x$parameter)
url <- urltools::url_compose(x)
# trim trailing ?
sub("\\?$", "", url)
}
# drop_param(url="https://hb.opencpu.org/get?foo=bar&baz=3&z=4", name="z")
# => "https://hb.opencpu.org/get?foo=bar&baz=3"
drop_param <- function(url, name) {
assert(name, "character")
stopifnot("can only drop one name at a time" = length(name) == 1)
z <- parseurl(url)
z$parameter[[name]] <- NULL
buildurl(z)
}
# replace_param(url="https://hb.opencpu.org/get?foo=5", name="foo", value=4)
# => "https://hb.opencpu.org/get?foo=4"
# # return param value unchanged if param name not found
# replace_param(url="https://hb.opencpu.org/get?bar=3", name="foo", value=4)
# => "https://hb.opencpu.org/get?bar=3"
# # No params at all
# replace_param(url="https://hb.opencpu.org/get", name="foo", value=4)
# => "https://hb.opencpu.org/get"
replace_param <- function(url, name, value) {
assert(name, "character")
stopifnot("can only replace one name at a time" = length(name) == 1)
z <- parseurl(url)
if (!is.list(z$parameter)) return(url)
if (is.null(z$parameter[[name]])) return(url)
z$parameter[[name]] <- value
buildurl(z)
}
replace_param_with <- function(url, name, fake, real) {
assert(name, "character")
stopifnot("can only replace one name at a time" = length(name) == 1)
z <- parseurl(url)
if (!is.list(z$parameter)) return(url)
if (is.null(z$parameter[[name]])) return(url)
z$parameter[[name]] <- sub(fake, real, z$parameter[[name]])
buildurl(z)
}
|
