1 files changed, 210 insertions, 0 deletions
diff --git a/R/http.R b/R/http.R
new file mode 100644
index 0000000..6ef4511
--- /dev/null
+++ b/R/http.R
@@ -0,0 +1,210 @@
+elapsed <- function() {
+  proc.time()[["elapsed"]]
+}
+
+MONTH_NUMBERS <- c(
+  Jan = 1L, Feb = 2L, Mar = 3L, Apr = 4L, May = 5L, Jun = 6L,
+  Jul = 7L, Aug = 8L, Sep = 9L, Oct = 10L, Nov = 11L, Dec = 12L
+)
+
+http_date_seconds <- function(value) {
+  parts <- regmatches(
+    value,
+    regexec(
+      paste0(
+        "^[A-Za-z]{3}, ([0-9]{2}) ([A-Za-z]{3}) ([0-9]{4}) ",
+        "([0-9]{2}):([0-9]{2}):([0-9]{2}) GMT$"
+      ),
+      value
+    )
+  )[[1L]]
+  if (length(parts) != 7L) {
+    return(NULL)
+  }
+  month <- MONTH_NUMBERS[parts[3L]]
+  if (is.na(month)) {
+    return(NULL)
+  }
+  target <- ISOdatetime(
+    as.integer(parts[4L]), month, as.integer(parts[2L]),
+    as.integer(parts[5L]), as.integer(parts[6L]), as.integer(parts[7L]),
+    tz = "GMT"
+  )
+  if (is.na(target)) {
+    return(NULL)
+  }
+  max(0, as.numeric(difftime(target, Sys.time(), units = "secs")))
+}
+
+retry_after_seconds <- function(value) {
+  if (is.null(value) || length(value) != 1L || is.na(value)) {
+    return(NULL)
+  }
+  value <- trimws(value)
+  if (!nzchar(value)) {
+    return(NULL)
+  }
+  seconds <- suppressWarnings(as.numeric(value))
+  if (!is.na(seconds)) {
+    return(max(0, seconds))
+  }
+  http_date_seconds(value)
+}
+
+backoff_wait <- function(client, attempt, retry_after) {
+  if (!is.null(retry_after)) {
+    return(min(retry_after, client$backoff_max))
+  }
+  ceiling <- min(client$backoff_base * 2^(attempt - 1L), client$backoff_max)
+  stats::runif(1L, 0, ceiling)
+}
+
+cepis_handle <- function(client) {
+  handle <- curl::new_handle()
+  curl::handle_setheaders(
+    handle,
+    "User-Agent" = client$user_agent,
+    "Accept" = "application/json, text/csv;q=0.9, */*;q=0.1",
+    "Accept-Encoding" = "identity"
+  )
+  curl::handle_setopt(
+    handle,
+    connecttimeout_ms = as.integer(client$timeout * 1000),
+    timeout_ms = as.integer(client$timeout * 1000)
+  )
+  handle
+}
+
+cepis_fetch <- function(client, path, accepted_status = 200L) {
+  url <- paste0(client$base_url, path)
+  deadline <- if (is.null(client$total_timeout)) {
+    NULL
+  } else {
+    elapsed() + client$total_timeout
+  }
+
+  last_status <- NULL
+  last_retry_after <- NULL
+  last_message <- NULL
+
+  for (attempt in seq_len(client$max_attempts)) {
+    if (!is.null(deadline) && elapsed() >= deadline) {
+      break
+    }
+
+    response <- tryCatch(
+      curl::curl_fetch_memory(url, handle = cepis_handle(client)),
+      error = function(e) e
+    )
+
+    if (inherits(response, "condition")) {
+      last_status <- NULL
+      last_retry_after <- NULL
+      last_message <- conditionMessage(response)
+    } else {
+      status <- as.integer(response$status_code)
+      headers <- curl::parse_headers_list(response$headers)
+      if (status %in% accepted_status || !(status %in% RETRIABLE_STATUS)) {
+        return(list(status = status, body = response$content,
+                    headers = headers))
+      }
+      last_status <- status
+      last_retry_after <- retry_after_seconds(headers[["retry-after"]])
+      last_message <- NULL
+    }
+
+    if (attempt == client$max_attempts) {
+      break
+    }
+
+    wait <- backoff_wait(client, attempt, last_retry_after)
+    if (!is.null(deadline)) {
+      remaining <- deadline - elapsed()
+      if (remaining <= 0) {
+        break
+      }
+      wait <- min(wait, remaining)
+    }
+    Sys.sleep(wait)
+  }
+
+  attempts <- paste0(" (after ", client$max_attempts, " attempt(s))")
+  if (identical(last_status, 429L)) {
+    stop(rate_limited_error(
+      paste0("rate limit reached at ", url, attempts),
+      retry_after = last_retry_after
+    ))
+  }
+  if (!is.null(last_status)) {
+    stop(server_error(
+      paste0("the API answered ", last_status, " at ", url, attempts),
+      status = last_status
+    ))
+  }
+  stop(network_error(
+    paste0("could not reach ", url, attempts, ": ", last_message),
+    url = url
+  ))
+}
+
+decode_body <- function(body) {
+  if (length(body) >= 3L &&
+      identical(as.integer(body[1:3]), c(239L, 187L, 191L))) {
+    body <- body[-(1:3)]
+  }
+  text <- rawToChar(body)
+  Encoding(text) <- "UTF-8"
+  text
+}
+
+json_object <- function(body) {
+  text <- decode_body(body)
+  data <- tryCatch(
+    jsonlite::parse_json(text, simplifyVector = FALSE),
+    error = function(e) e
+  )
+  if (inherits(data, "condition") || !is.list(data) ||
+      (length(data) > 0L && is.null(names(data)))) {
+    stop(invalid_response_error(paste0(
+      "response is not a JSON object - something between you and the API is ",
+      "answering instead of it: ", substr(text, 1L, 120L)
+    )))
+  }
+  data
+}
+
+api_message <- function(body, fallback) {
+  data <- tryCatch(
+    jsonlite::parse_json(decode_body(body), simplifyVector = FALSE),
+    error = function(e) NULL
+  )
+  message <- if (is.list(data)) data[["mensagem"]] else NULL
+  if (is.character(message) && length(message) == 1L && nzchar(message)) {
+    message
+  } else {
+    fallback
+  }
+}
+
+csv_rows <- function(body) {
+  path <- tempfile(fileext = ".csv")
+  on.exit(unlink(path), add = TRUE)
+  writeBin(body, path)
+
+  table <- tryCatch(
+    utils::read.csv(
+      path,
+      colClasses = "character",
+      na.strings = character(0L),
+      check.names = FALSE,
+      encoding = "UTF-8"
+    ),
+    error = function(e) e
+  )
+  if (inherits(table, "condition")) {
+    stop(invalid_response_error(paste0(
+      "batch response is not valid CSV: ", conditionMessage(table)
+    )))
+  }
+  table
+}