Tools to Work with the 'Splash' JavaScript Rendering Service in R
Вы не можете выбрать более 25 тем Темы должны начинаться с буквы или цифры, могут содержать дефисы(-) и должны содержать не более 35 символов.

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241
  1. #' Retrieve the body content of a HAR entry
  2. #'
  3. #' @md
  4. #' @param har_resp_obj HAR response object
  5. #' @param type return type. If `raw` (default) then a raw vector of the content is returned.
  6. #' If `text` then a character vector.
  7. #' @family splash_har_helpers
  8. #' @return A `raw` vector of the content or `NULL` or a `character` if `type` == `text`
  9. #' @export
  10. get_response_body <- function(har_resp_obj, type=c("raw", "text")) {
  11. type <- match.arg(type, c("raw", "text"))
  12. resp <- har_resp_obj$response$content$text
  13. if (resp == "") return(NULL)
  14. tmp <- openssl::base64_decode(resp)
  15. if (type == "text") tmp <- readBin(tmp, "character")
  16. tmp
  17. }
  18. #' Retrieve or test content type of a HAR request object
  19. #'
  20. #' @param har_resp_obj a reponse object from [render_har()] or [execute_lua()]
  21. #' @family splash_har_helpers
  22. #' @export
  23. get_content_type <- function(har_resp_obj) {
  24. ctype <- har_resp_obj$response$content$mimeType
  25. if (ctype == "") return(NA_character_)
  26. if (any(grepl(";", ctype))) ctype <- gsub(";.*$", "", ctype)
  27. ctype
  28. }
  29. #' @md
  30. #' @rdname get_content_type
  31. #' @param type content type to compare to (default: "`application/json`")
  32. #' @export
  33. is_content_type <- function(har_resp_obj, type="application/json") {
  34. res <- get_content_type(har_resp_obj) == type
  35. if (is.na(res)) res <- FALSE
  36. res
  37. }
  38. #' @rdname get_content_type
  39. #' @export
  40. is_json <- function(har_resp_obj) { is_content_type(har_resp_obj) }
  41. #' @rdname get_content_type
  42. #' @export
  43. is_xml <- function(har_resp_obj) { is_content_type(har_resp_obj, type="application/xml") }
  44. #' @rdname get_content_type
  45. #' @export
  46. is_css <- function(har_resp_obj) { is_content_type(har_resp_obj, type="text/css") }
  47. #' @rdname get_content_type
  48. #' @export
  49. is_plain <- function(har_resp_obj) { is_content_type(har_resp_obj, type="text/plain") }
  50. #' @rdname get_content_type
  51. #' @export
  52. is_binary <- function(har_resp_obj) { is_content_type(har_resp_obj, type="application/octet-stream") }
  53. #' @rdname get_content_type
  54. #' @export
  55. is_javascript <- function(har_resp_obj) {
  56. is_content_type(har_resp_obj, type="text/javascript") |
  57. is_content_type(har_resp_obj, type="text/x-javascript")
  58. }
  59. #' @rdname get_content_type
  60. #' @export
  61. is_html <- function(har_resp_obj) { is_content_type(har_resp_obj, type="text/html") }
  62. #' @rdname get_content_type
  63. #' @export
  64. is_jpeg <- function(har_resp_obj) { is_content_type(har_resp_obj, type="image/jpeg") }
  65. #' @rdname get_content_type
  66. #' @export
  67. is_png <- function(har_resp_obj) { is_content_type(har_resp_obj, type="image/png") }
  68. #' @rdname get_content_type
  69. #' @export
  70. is_svg <- function(har_resp_obj) { is_content_type(har_resp_obj, type="image/svg+xml") }
  71. #' @rdname get_content_type
  72. #' @export
  73. is_gif <- function(har_resp_obj) { is_content_type(har_resp_obj, type="image/gif") }
  74. #' @rdname get_content_type
  75. #' @export
  76. is_xhr <- function(har_resp_obj) {
  77. if (is.null(har_resp_obj$request$headers)) return(NA)
  78. if (length(har_resp_obj$request$headers)==0) return(NA)
  79. y <- map(har_resp_obj$request$headers, "value")
  80. names(y) <- tolower(map_chr(har_resp_obj$request$headers, "name"))
  81. if ("x-requested-with" %in% names(y)) {
  82. return(tolower("xmlhttprequest") == tolower(y[["x-requested-with"]]))
  83. } else {
  84. return(FALSE)
  85. }
  86. }
  87. #' Retrieve response headers as a data frame
  88. #'
  89. #' @md
  90. #' @param har_resp_obj HAR response object
  91. #' @note the `name` column that contains the header key is normalized to lower case
  92. #' @family splash_har_helpers
  93. #' @export
  94. get_headers <- function(har_resp_obj) {
  95. if (length(har_resp_obj$response$headers)) {
  96. do.call(
  97. rbind.data.frame,
  98. lapply(har_resp_obj$response$headers, as.data.frame, stringsAsFactors=FALSE)
  99. ) -> ret
  100. ret[["name"]] <- tolower(ret[["name"]])
  101. class(ret) <- c("tbl_df", "tbl", "data.frame")
  102. ret
  103. }
  104. }
  105. #' Retrieve the value of a specific response header
  106. #'
  107. #' @md
  108. #' @param har_resp_obj HAR response object
  109. #' @param header the header you want the value for
  110. #' @note the `name` column that contains the header key is normalized to lower case
  111. #' as is the passed-in requested header. Also, if there is more than one only
  112. #' the first is returned.
  113. #' @family splash_har_helpers
  114. #' @export
  115. get_header_val <- function(har_resp_obj, header) {
  116. if (length(har_resp_obj$response$headers)) {
  117. header <- tolower(header)
  118. do.call(
  119. rbind.data.frame,
  120. lapply(har_resp_obj$response$headers, as.data.frame, stringsAsFactors=FALSE)
  121. ) -> ret
  122. ret[["name"]] <- tolower(ret[["name"]])
  123. ret <- unlist(ret[ret$name == header, "value"], use.names = FALSE)
  124. if (length(ret)) ret <- ret[1] else ret <- NA_character_
  125. ret
  126. } else {
  127. NA_character_
  128. }
  129. }
  130. #' Retrieve request URL
  131. #'
  132. #' @param har_resp_obj HAR response object
  133. #' @family splash_har_helpers
  134. #' @export
  135. get_request_url <- function(har_resp_obj) {
  136. utype <- har_resp_obj$request$url
  137. if (utype == "") utype <- NA_character_
  138. utype
  139. }
  140. #' Retrieve response URL
  141. #'
  142. #' @param har_resp_obj HAR response object
  143. #' @family splash_har_helpers
  144. #' @export
  145. get_response_url <- function(har_resp_obj) {
  146. utype <- har_resp_obj$response$url
  147. if (utype == "") utype <- NA_character_
  148. utype
  149. }
  150. #' Retrieve or test request type
  151. #'
  152. #' @param har_resp_obj HAR response object
  153. #' @family splash_har_helpers
  154. #' @export
  155. get_request_type <- function(har_resp_obj) {
  156. rtype <- har_resp_obj$request$method
  157. if (rtype == "") return(NA_character_)
  158. rtype
  159. }
  160. #' @rdname get_request_type
  161. #' @export
  162. is_get <- function(har_resp_obj) { get_request_type(har_resp_obj) == "GET" }
  163. #' @rdname get_request_type
  164. #' @export
  165. is_post <- function(har_resp_obj) { get_request_type(har_resp_obj) == "POST" }
  166. #' Retrieve just the HAR entries from a splashr request
  167. #'
  168. #' @param x can be a `har` object, `harlog` object or `harentries` object
  169. #' @export
  170. har_entries <- function(x) {
  171. if (inherits(x, "har")) {
  172. x$log$entries
  173. } else if (inherits(x, "harlog")) {
  174. x$entries
  175. } else if (inherits(x, "harentries")) {
  176. x
  177. } else {
  178. NULL
  179. }
  180. }
  181. #' Retrieve an entry by index from a HAR object
  182. #'
  183. #' @param x can be a `har` object, `harlog` object or `harentries` object
  184. #' @param i index of the HAR entry to retrieve
  185. #' @family splash_har_helpers
  186. #' @export
  187. get_har_entry <- function(x, i=1) {
  188. if (inherits(x, "har")) {
  189. x$log$entries[[i]]
  190. } else if (inherits(x, "harlog")) {
  191. x$entries[[i]]
  192. } else if (inherits(x, "harentries")) {
  193. x[[i]]
  194. } else {
  195. NULL
  196. }
  197. }
  198. #' Retrieves number of HAR entries in a response
  199. #'
  200. #' @param x can be a `har` object, `harlog` object or `harentries` object
  201. #' @family splash_har_helpers
  202. #' @export
  203. har_entry_count <- function(x) {
  204. if (inherits(x, "har")) {
  205. length(x$log$entries)
  206. } else if (inherits(x, "harlog")) {
  207. length(x$entries)
  208. } else if (inherits(x, "harentries")) {
  209. length(x)
  210. } else {
  211. NULL
  212. }
  213. }