More tests

r-hub · Apr 8, 2024 · 62192fc · 62192fc
1 parent f433870
commit 62192fc
Show file tree

Hide file tree

Showing 7 changed files with 380 additions and 8 deletions.
diff --git a/.Rbuildignore b/.Rbuildignore
@@ -19,3 +19,4 @@
 ^README[.]html$
 ^rhub2\.Rproj$
 ^\.Rproj\.user$
+^dev-lib$
diff --git a/R/api.R b/R/api.R
@@ -1,5 +1,5 @@
 baseurl <- function() {
-  paste0(Sys.getenv("RHUB_SERVER", "https://builder2.rhub.io"), "/api/-")
+  Sys.getenv("RHUB_SERVER", "https://builder2.rhub.io/api/-")
 }
 
 default_headers <- c(
@@ -64,13 +64,18 @@ query_sse_async <- function(method, url, headers, data, data_form) {
   handle_sse <- function(evt) {
     msgs <<- c(msgs, list(evt))
     if (evt[["event"]] == "progress") {
-      msg <- jsonlite::fromJSON(evt[["data"]])
-      cli::cli_alert(msg, .envir = emptyenv())
+      # ignore malformed event messages
+      tryCatch({
+        msg <- jsonlite::fromJSON(evt[["data"]])
+        cli::cli_alert(msg, .envir = emptyenv())
+      }, error = function(e) NULL)
     } else if (evt[["event"]] == "result") {
       cli::cli_alert_success("Done.")
     } else if (evt[["event"]] == "error") {
-      msg <- jsonlite::fromJSON(evt[["data"]])
-      cli::cli_alert_danger(msg, .envir = emptyenv())
+      tryCatch({
+        msg <- jsonlite::fromJSON(evt[["data"]])
+        cli::cli_alert_danger(msg, .envir = emptyenv())
+      }, error = function(e) cli::cli_alert_danger("Error from server"))
       stop("Aborting")
     }
   }

diff --git a/R/rhub-app.R b/R/rhub-app.R
@@ -0,0 +1,10 @@
+# nocov start
+
+rhub_app <- function() {
+  app <- webfakes::new_app()
+  app$use("json body parser" = webfakes::mw_json())
+
+  app
+}
+
+# nocov end
diff --git a/tests/testthat/_snaps/api.md b/tests/testthat/_snaps/api.md
@@ -0,0 +1,198 @@
+# query GET
+
+    Code
+      cat(rawToChar(query("/get")$content))
+    Output
+      {
+        "args": {},
+        "headers": {
+          "Host": "127.0.0.1:<port>",
+          "Accept-Encoding": "deflate, gzip",
+          "accept": "application/json",
+          "content-type": "application/json",
+          "user-agent": "R-hub client"
+        },
+        "origin": "127.0.0.1",
+        "path": "/get",
+        "url": "http://127.0.0.1:<port>/get"
+      }
+
+# query HTTP errors
+
+    Code
+      query("/rhub-error?msg=iamsosorryabouththat")
+    Condition
+      Error:
+      ! iamsosorryabouththat
+      Caused by error:
+      ! Unauthorized (HTTP 401).
+
+---
+
+    Code
+      query("/rhub-error2")
+    Condition
+      Error:
+      ! Unauthorized (HTTP 401).
+
+---
+
+    Code
+      query("/rhub-error3")
+    Condition
+      Error:
+      ! Unauthorized (HTTP 401).
+
+# query POST
+
+    Code
+      cat(rawToChar(query("/post", method = "POST", data = data)$content))
+    Output
+      {
+        "args": {},
+        "data": "{\"foo\":[\"bar\"],\"foobar\":[1,2,3]}",
+        "files": {},
+        "form": {},
+        "headers": {
+          "Host": "127.0.0.1:<port>",
+          "Accept-Encoding": "deflate, gzip",
+          "accept": "application/json",
+          "content-type": "application/json",
+          "user-agent": "R-hub client",
+          "Content-Length": "32"
+        },
+        "json": {
+          "foo": [
+            "bar"
+          ],
+          "foobar": [
+            1,
+            2,
+            3
+          ]
+        },
+        "method": "post",
+        "path": "/post",
+        "origin": "127.0.0.1",
+        "url": "http://127.0.0.1:<port>/post"
+      }
+
+# query, unknown verb
+
+    Code
+      query("/anything", method = "REPORT")
+    Condition
+      Error:
+      ! Unexpected HTTP verb, internal rhub error
+    Code
+      query("/anything", method = "REPORT", sse = TRUE)
+    Condition
+      Error:
+      ! Unexpected HTTP verb, internal rhub error
+
+# query SSE
+
+    Code
+      query("/sse", sse = TRUE)$sse
+    Output
+      [[1]]
+                        event                 message 
+                          "1" "live long and prosper" 
+      
+      [[2]]
+                        event                 message 
+                          "2" "live long and prosper" 
+      
+      [[3]]
+                        event                 message 
+                          "3" "live long and prosper" 
+      
+      [[4]]
+                        event                 message 
+                          "4" "live long and prosper" 
+      
+      [[5]]
+                        event                 message 
+                          "5" "live long and prosper" 
+      
+    Code
+      query("/sse", method = "POST", data = data, sse = TRUE)$sse
+    Output
+      [[1]]
+                        event                 message 
+                          "1" "live long and prosper" 
+      
+      [[2]]
+                        event                 message 
+                          "2" "live long and prosper" 
+      
+      [[3]]
+                        event                 message 
+                          "3" "live long and prosper" 
+      
+      [[4]]
+                        event                 message 
+                          "4" "live long and prosper" 
+      
+      [[5]]
+                        event                 message 
+                          "5" "live long and prosper" 
+      
+
+---
+
+    Code
+      resp <- query("/sse?progress=true&numevents=2", sse = TRUE)
+    Message
+      > This is `it`: 1
+      > This is `it`: 2
+      v Done.
+    Code
+      cat(rawToChar(resp$content))
+    Output
+      event: 1
+      message: live long and prosper
+      
+      event: progress
+      data: "This is {.code it}: 1"
+      
+      event: 2
+      message: live long and prosper
+      
+      event: progress
+      data: "This is {.code it}: 2"
+      
+      event: result
+      data: "All is {.code good}."
+      
+
+---
+
+    Code
+      resp <- query("/sse?progress=true&numevents=2&error=true", sse = TRUE)
+    Message
+      > This is `it`: 1
+      > This is `it`: 2
+      x This is a `failure`.
+    Condition
+      Error:
+      ! Aborting
+    Code
+      cat(rawToChar(resp$content))
+    Output
+      event: 1
+      message: live long and prosper
+      
+      event: progress
+      data: "This is {.code it}: 1"
+      
+      event: 2
+      message: live long and prosper
+      
+      event: progress
+      data: "This is {.code it}: 2"
+      
+      event: result
+      data: "All is {.code good}."
+      
+
diff --git a/tests/testthat/helpers.R b/tests/testthat/helpers.R
@@ -0,0 +1,104 @@
+http_app <- function() {
+  app <- webfakes::httpbin_app()
+
+  # An error with a JSON response that has a 'message'
+  app$get("/rhub-error", function(req, res) {
+    msg <- req$query[["msg"]]
+    status <- as.integer(req$query[["status"]] %||% 401)
+    res$
+      set_status(status)$
+      send_json(object = list(message = msg))
+  })
+
+  # An error with an invalid JSON response
+  app$get("/rhub-error2", function(req, res) {
+    status <- as.integer(req$query[["status"]] %||% 401)
+    res$
+      set_status(status)$
+      send_json(text = "[this is not valid json]")
+  })
+
+  # An error with a JSON response, without a 'message'
+  app$get("/rhub-error3", function(req, res) {
+    status <- as.integer(req$query[["status"]] %||% 401)
+    res$
+      set_status(status)$
+      send_json(object = list(foo = "bar"))
+  })
+
+  # SSE
+  sse <- function(req, res) {
+    `%||%` <- function(l, r) if (is.null(l)) r else l
+    if (is.null(res$locals$sse)) {
+      progress <- !is.null(req$query$progress)
+      error <- !is.null(req$query$error)
+      duration <- as.double(req$query$duration %||% 2)
+      delay <- as.double(req$query$delay %||% 0)
+      numevents <- as.integer(req$query$numevents %||% 5)
+      pause <- max(duration / numevents, 0.01)
+      res$locals$sse <- list(
+        sent = 0,
+        numevents = numevents,
+        pause = pause,
+        progress = progress,
+        error = error
+      )
+
+      res$
+        set_header("cache-control", "no-cache")$
+        set_header("content-type", "text/event-stream")$
+        set_header("access-control-allow-origin", "*")$
+        set_header("connection", "keep-alive")$
+        set_status(200)
+
+      if (delay > 0) {
+        return(res$delay(delay))
+      }
+    }
+
+    msg <- paste0(
+      "event: ", res$locals$sse$sent + 1L, "\n",
+      "message: live long and prosper\n\n"
+    )
+    res$locals$sse$sent <- res$locals$sse$sent + 1L
+    res$write(msg)
+
+    if (res$locals$sse$progress) {
+      msg <- paste0(
+        "event: progress\n",
+        "data: \"This is {.code it}: ", res$locals$sse$sent, "\"\n\n"
+      )
+      res$write(msg)
+    }
+
+    if (res$locals$sse$sent == res$locals$sse$numevents) {
+      if (res$locals$sse$progress) {
+        msg <- if (res$locals$sse$error) {
+          paste0(
+            "event: error\n",
+            "data: \"This is a {.code failure}.\"\n\n"
+          )
+        } else {
+          paste0(
+            "event: result\n",
+            "data: \"All is {.code good}.\"\n\n"
+          )
+        }
+        res$write(msg)
+      }
+      res$send("")
+    } else {
+      res$delay(res$locals$sse$pause)
+    }
+  }
+  app$get("/sse", sse)
+  app$post("/sse", sse)
+
+  app
+}
+
+http <- webfakes::new_app_process(http_app())
+
+redact_port <- function(x) {
+  gsub(":[0-9]+", ":<port>", x)
+}