Hotswap resources (#11)

1. Added hot swapping of images and stylesheets without a hard refresh of the server


Non-user facing:
2. Implemented passing messages with payloads to the web client to allow for targeted client updates 
3. Debounce hard refreshes and hot swaps
4. Replace the html injection file with a javascript file for future upkeep

Author: ElianHugh

.gitignore

@@ -51,3 +51,6 @@ rsconnect/
 # debug files
 .fuse_hidden*
 docs
+
+
+.DS_STORE

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: hotwater
 Title: Live Reload for Plumber APIs
-Version: 0.0.0.9002
+Version: 0.0.0.9003
 Authors@R:
     person("Elian", "Thiele-Evans", , "elianhte@gmail.com", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-8008-3165"))
@@ -16,7 +16,8 @@ Imports:
     mirai,
     plumber (>= 0.4.0),
     utils,
-    stats
+    stats,
+    jsonlite
 Suggests:
     box,
     docopt,

R/cli.R

@@ -16,6 +16,11 @@ cli_file_changed <- function(changes) {
     cli::cli_alert("{.file {changes}} changed!")
 }
 
+cli_hot_swapped <- function(changes) {
+    n <- length(changes)
+    cli::cli_inform("Hot swapped assets ({n} file{?s}): {.file {changes}}")
+}
+
 cli_server_start_progress <- function(engine) {
     cli::cli_progress_step(
         msg = "Starting plumber server on {.url {engine$config$host}:{engine$config$port}}",

R/config.R

@@ -13,7 +13,34 @@ new_config <- function(...) {
     ignore <- dots$ignore %||%
         utils::glob2rx(
             paste(
-                c("*.sqlite", "*.git*"),
+                c(
+                    # dbs
+                    "*.sqlite",
+                    "*.sqlite3",
+                    "*.db",
+                    "*.db-journal",
+                    "*.db-wal",
+                    "*.db-shm",
+
+                    #os
+                    ".DS_Store",
+                    "Thumbs.db",
+
+                    # git
+                    "*.git*",
+                    ".git/*",
+                    ".gitignore",
+                    ".gitmodules",
+
+                    # R
+
+                    ".Rhistory",
+                    ".RData",
+                    ".Ruserdata",
+                    ".Rproj.user/*",
+
+                    "*/.*"
+                ),
                 collapse = "|"
             )
         )

R/engine.R

@@ -32,11 +32,57 @@ new_engine <- function(config) {
     eng
 }
 
+hot_swappable <- c(
+    "css",
+    "png",
+    "jpg",
+    "jpeg",
+    "gif",
+    "svg",
+    "webp",
+    "ico",
+    "avif"
+)
+
 run_engine <- function(engine) {
+    restart_pending <- FALSE
+    restart_due_at <- NULL
+    pending_restart_changes <- character()
+    restart_ms <- 300L
+
+    hotswap_pending <- FALSE
+    hotswap_due_at <- NULL
+    pending_hotswap_changes <- character()
+    hotswap_ms <- 120L
+
+
     callback <- function(changes) {
-        cli_file_changed(changes)
-        teardown_engine(engine)
-        buildup_engine(engine)
+
+        changed_files <- unique(unlist(changes, use.names = FALSE))
+
+        exts <- tolower(tools::file_ext(changed_files))
+
+        is_hot_swappable <- length(exts) > 0L &&
+            all(exts %in% hot_swappable)
+
+
+
+        if (is_hot_swappable) {
+            hotswap_pending <<- TRUE
+            pending_hotswap_changes <<- unique(c(
+                pending_hotswap_changes,
+                changed_files
+            ))
+            hotswap_due_at <<- Sys.time() + hotswap_ms / 1000
+
+        } else {
+            restart_pending <<- TRUE
+            pending_restart_changes <<- unique(c(
+                pending_restart_changes,
+                changed_files
+            ))
+            restart_due_at <<- Sys.time() + restart_ms / 1000
+        }
     }
     on.exit({
         teardown_engine(engine)
@@ -57,11 +103,52 @@ run_engine <- function(engine) {
     repeat {
         Sys.sleep(0.05) # todo, allow this to be configured at some point
         drain_runner_log(engine)
+
+        if (
+            !isTRUE(restart_pending) &&
+            isTRUE(hotswap_pending) &&
+                Sys.time() >= hotswap_due_at
+        ) {
+            json <- jsonlite::toJSON(
+                list(
+                    type = "HW::resource",
+                    targets = list(pending_hotswap_changes)
+                ),
+                auto_unbox = TRUE
+            )
+            nanonext::send(
+                engine$publisher,
+                json,
+                mode = "raw"
+            )
+            cli_hot_swapped(pending_hotswap_changes)
+
+            hotswap_pending <- FALSE
+            hotswap_due_at <- NULL
+            pending_hotswap_changes <- character()
+        }
+
+        if (isTRUE(restart_pending) && Sys.time() >= restart_due_at) {
+            cli_file_changed(pending_restart_changes)
+            restart_pending <- FALSE
+            restart_due_at <- NULL
+            pending_restart_changes <- character()
+
+            hotswap_pending <- FALSE
+            hotswap_due_at <- NULL
+            pending_hotswap_changes <- character()
+
+
+            teardown_engine(engine)
+            buildup_engine(engine)
+        }
+
         current_state <- watch_directory(
             engine,
             current_state,
             callback
         )
+
     }
 }
 
@@ -87,13 +174,13 @@ buildup_engine <- function(engine) {
 
     if (!res) {
         cli::cli_progress_done(result = "failed")
+        stop("Failed to start Plumber server.")
     } else {
         publish_browser_reload(engine)
         cli::cli_progress_done()
+        cli_watching_directory(engine)
+        drain_runner_log(engine)
     }
-
-    cli_watching_directory(engine)
-    drain_runner_log(engine)
 }
 
 teardown_engine <- function(engine) {
@@ -144,13 +231,38 @@ drain_runner_log <- function(engine) {
     engine$logpos <- size
 
     if (nzchar(data)) {
+        if (grepl("=== HOTWATER_ERROR_BEGIN ===", data)) {
+            msg <- sub(
+            ".*=== HOTWATER_ERROR_BEGIN ===\\s*([\\s\\S]*?)\\s*=== HOTWATER_ERROR_END ===.*",
+            "\\1",
+            data,
+            perl = TRUE
+            )
+            msg <- trimws(msg)
+            json <- jsonlite::toJSON(
+                list(
+                    type = "HW::error",
+                    error = msg
+                ),
+                auto_unbox = TRUE
+            )
+
+            nanonext::send(
+                engine$publisher,
+                json,
+                mode = "raw"
+            )
+        }
+
         data <- gsub(
             "=== HOTWATER_ERROR_BEGIN ===\\s*([\\s\\S]*?)\\s*=== HOTWATER_ERROR_END ===",
             cli::col_red("\\1"),
             data,
             perl = TRUE
         )
 
+
+
         data <- gsub(
             "=== HOTWATER_WARNING_BEGIN ===\\s*([\\s\\S]*?)\\s*=== HOTWATER_WARNING_END ===",
             cli::col_yellow("\\1"),

R/middleware.R

@@ -3,32 +3,56 @@
 
 injection <- function(engine) {
     injection_lines <- readLines(
-        system.file("middleware", "injection.html", package = "hotwater", mustWork = TRUE)
+        system.file(
+            "middleware",
+            "hotwater-client.js",
+            package = "hotwater",
+            mustWork = TRUE
+        )
     )
-
     sprintf(
         paste(injection_lines, collapse = "\n"),
         engine$publisher$listener[[1L]]$url
     )
 }
 
+
 middleware <- function(engine) {
-    js <- injection(engine)
+    js <- '<script src="/__hotwater__/client.js"></script>'
+    js_path <- injection(engine)
+
+
     hook <- postserialise_hotwater(js)
+    pid <- Sys.getpid()
     function(pr) {
         # remove hotwater from the api spec
         plumber::pr_set_api_spec(pr, function(spec) {
             spec$paths[["/__hotwater__"]] <- NULL
+            spec$paths[["/__hotwater__/client.js"]] <- NULL
             spec
         })
         # the dummy path is needed for pinging the server from hotwater
         plumber::pr_get(
             pr,
             "/__hotwater__",
-            function() "running",
+            function() pid,
             serializer = plumber::serializer_text(),
             preempt = "__first__"
         )
+        plumber::pr_get(
+            pr,
+            "/__hotwater__/client.js",
+            function(req, res) {
+                res$setHeader("Cache-Control", "no-store")
+                js_path
+            },
+            serializer = plumber::serializer_content_type(
+                "application/javascript",
+                function(val) {
+                    as.character(val)
+                }
+            )
+        )
         plumber::pr_hook(
             pr,
             "postserialize",
@@ -51,11 +75,11 @@ postserialise_hotwater <- function(js) {
 }
 
 publish_browser_reload <- function(engine) {
-    # at the moment, the message itself is largely meaningless because we're faking the
-    # protocol on the javascript side of things
-    # may be worth getting a minimal protocol working down the line on the JS side so we can send
-    # specific messages to the browser
-    nanonext::send(engine$publisher, "start")
+    json <- jsonlite::toJSON(
+        list(type = "HW::page"),
+        auto_unbox = TRUE
+    )
+    nanonext::send(engine$publisher, json, mode="raw")
 }
 
 is_plumber_running <- function(engine) {
@@ -66,10 +90,13 @@ is_plumber_running <- function(engine) {
                 engine$config$host,
                 engine$config$port
             )
-            res <- httr2::resp_status(
-                httr2::req_perform(httr2::request(url))
-            )
-            res == 200L
+
+            req <- httr2::request(url)
+            resp <- httr2::req_perform(req)
+            status <- httr2::resp_status(resp)
+            content <- httr2::resp_body_string(resp)
+
+            status == 200L && as.integer(content) == Sys.getpid()
         },
         error = function(e) {
             FALSE

R/mirai.R

@@ -96,7 +96,7 @@ new_runner <- function(engine) {
         Sys.sleep(0.1)
     }
 
-    if (i == timeout && !is_plumber_running(engine)) {
+    if (!is_runner_alive(engine) || !is_plumber_running(engine)) {
         return(FALSE)
     }
 

R/watcher.R

@@ -5,7 +5,9 @@ watch_directory <- function(engine, current_state, callback) {
     )
     next_state <- directory_state(paths, engine$config$ignore)
     changed_files <- get_changed_files(current_state, next_state)
-    if (did_files_change(changed_files)) {
+
+
+    if (did_files_change(unique(unlist(changed_files)))) {
         callback(changed_files)
         return(next_state)
     }
@@ -16,19 +18,25 @@ get_changed_files <- function(current_state, next_state) {
     new <- names(next_state[names(next_state) %nin% names(current_state)])
     removed <- names(current_state[names(current_state) %nin% names(next_state)])
     modified <- names(next_state[next_state %nin% current_state])
-    unique(c(new, removed, modified))
+    list(new = new, removed = removed, modified = modified)
 }
 
-did_files_change <- function(changed_files) {
-    length(changed_files) > 0L
+did_files_change <- function(...) {
+    any(lengths(as.list(...))) > 0L
 }
 
 directory_state <- function(paths, ignore_pattern) {
+    paths <- paths[dir.exists(paths)]
+
+      if (length(paths) == 0L) {
+        return(stats::setNames(numeric(0), character(0)))
+    }
+
     res <- file.info(
         list.files(paths, full.names = TRUE, recursive = TRUE, all.files = TRUE),
         extra_cols = FALSE
     )
     res <- res[grep(pattern = ignore_pattern, x = row.names(res), invert = TRUE), ]
-    res <- res[res$size > 0L, ]
+    res <- res[!is.na(res$size), ]
     stats::setNames(res$mtime, row.names(res))
 }