R/snapshot.R

In shinytest: Test Shiny Apps

sd_snapshotInit <- function(self, private, path, screenshot) {
  if (grepl("^/", path)) {
    abort("Snapshot dir must be a relative path.")
  }

  # Strip off trailing slash if present
  path <- sub("/$", "", path)

  private$snapshotCount <- 0
  private$snapshotDir <- path
  private$snapshotScreenshot <- screenshot
}

sd_snapshot <- function(self, private, items, filename, screenshot)
{
  if (!is.list(items) && !is.null(items))
    abort("'items' must be NULL or a list.")

  private$snapshotCount <- private$snapshotCount + 1

  current_dir  <- paste0(self$getSnapshotDir(), "-current")

  if (is.null(filename)) {
    filename <- sprintf("%03d.json", private$snapshotCount)
  }

  # The default is to take a screenshot when the snapshotScreenshot option is
  # TRUE and the user does not specify specific items to snapshot.
  if (is.null(screenshot)) {
    screenshot <- private$snapshotScreenshot && is.null(items)
  }

  # Figure out which items to snapshot ----------------------------------------
  # By default, record all items.
  if (is.null(items)) {
    items <- list(input = TRUE, output = TRUE, export = TRUE)
  }

  extra_names <- setdiff(names(items), c("input", "output", "export"))
  if (length(extra_names) > 0) {
    abort(paste0(
      "'items' must be a list containing one or more items named",
      "'input', 'output' and 'export'. Each of these can be TRUE, FALSE, ",
      " or a character vector."
    ))
  }

  if (is.null(items$input))  items$input  <- FALSE
  if (is.null(items$output)) items$output <- FALSE
  if (is.null(items$export)) items$export <- FALSE

  # Take snapshot -------------------------------------------------------------
  self$logEvent("Taking snapshot")
  url <- private$getTestSnapshotUrl(items$input, items$output, items$export)
  req <- httr_get(url)

  # For first snapshot, create -current snapshot dir.
  if (private$snapshotCount == 1) {
    if (dir_exists(current_dir)) {
      unlink(current_dir, recursive = TRUE)
    }
    dir.create(current_dir, recursive = TRUE)
  }

  # Convert to text, then replace base64-encoded images with hashes of them.
  content <- raw_to_utf8(req$content)
  content <- hash_snapshot_image_data(content)
  content <- jsonlite::prettify(content, indent = 2)
  write_utf8(content, file.path(current_dir, filename))

  if (screenshot) {
    # Replace extension with .png
    scr_filename <- paste0(sub("\\.[^.]*$", "", filename), ".png")
    self$takeScreenshot(file.path(current_dir, scr_filename))
  }

  # Invisibly return JSON content as a string
  invisible(raw_to_utf8(req$content))
}

sd_snapshotDownload <- function(self, private, id, filename) {

  current_dir <- paste0(self$getSnapshotDir(), "-current")

  private$snapshotCount <- private$snapshotCount + 1

  if (is.null(filename)) {
    filename <- sprintf("%03d.download", private$snapshotCount)
  }

  # Find the URL to download from (the href of the <a> tag)
  url <- self$findElement(paste0("#", id))$getAttribute("href")
  if (identical(url, "")) {
    stop("Download from '#", id, "' failed")
  }
  req <- httr_get(url)

  # For first snapshot, create -current snapshot dir.
  if (private$snapshotCount == 1) {
    if (dir_exists(current_dir)) {
      unlink(current_dir, recursive = TRUE)
    }
    dir.create(current_dir, recursive = TRUE)
  }

  writeBin(req$content, file.path(current_dir, filename))

  invisible(req$content)
}

sd_getTestSnapshotUrl = function(self, private, input, output, export,
                                 format) {
  reqString <- function(group, value) {
    if (isTRUE(value))
      paste0(group, "=1")
    else if (is.character(value))
      paste0(group, "=", paste(value, collapse = ","))
    else
      ""
  }
  paste(
    private$shinyTestSnapshotBaseUrl,
    reqString("input", input),
    reqString("output", output),
    reqString("export", export),
    paste0("format=", format),
    sep = "&"
  )
}

#' Compare current and expected snapshots
#'
#' This compares current and expected snapshots for a test set, and prints any
#' differences to the console.
#'
#' @param testnames Name or names of a test. If NULL, compare all test results.
#' @param appDir Directory that holds the tests for an application. This is the
#'   parent directory for the expected and current snapshot directories.
#' @param autoremove If the current results match the expected results, should
#'   the current results be removed automatically? Defaults to TRUE.
#' @param interactive If there are any differences between current results and
#'   expected results, provide an interactive graphical viewer that shows the
#'   changes and allows the user to accept or reject the changes.
#' @param quiet Should output be suppressed? This is useful for automated
#'   testing.
#' @param images Should screenshots and PNG images be compared? It can be useful
#'   to set this to `FALSE` when the expected results were taken on a
#'   different platform from the current results.
#' @param suffix An optional suffix for the expected results directory. For
#'   example, if the suffix is `"mac"`, the expected directory would be
#'   `mytest-expected-mac`.
#'
#' @seealso [testApp()]
#'
#' @keywords internal
#' @export
snapshotCompare <- function(
  appDir,
  testnames = NULL,
  autoremove = TRUE,
  images = TRUE,
  quiet = FALSE,
  interactive = is_interactive(),
  suffix = NULL
) {

  testDir <- findTestsDir(appDir, quiet=TRUE)
  if (is.null(testnames)) {
    testnames <- all_testnames(testDir, "-current")
  }

  results <- lapply(
    testnames,
    function(testname) {
      snapshotCompareSingle(appDir, testname, autoremove, quiet, images, interactive, suffix)
    }
  )

  if (!interactive && !quiet) {
    pass_idx <- vapply(results, `[[`, "pass", FUN.VALUE = FALSE)
    all_pass <- all(pass_idx)

    relativeAppDir <- getOption("shinytest.app.dir", default = appDir)

    if (!all_pass) {
      inform(paste0('\nTo view a textual diff, run:\n  viewTestDiff("', relativeAppDir, '", interactive = FALSE)'))
    }
  }

  invisible(structure(
    list(
      appDir = appDir,
      results = results,
      images = images
    ),
    class = "shinytest.results"
  ))
}


snapshotCompareSingle <- function(
  appDir,
  testname,
  autoremove = TRUE,
  quiet = FALSE,
  images = TRUE,
  interactive = is_interactive(),
  suffix = NULL
) {
  testDir <- findTestsDir(appDir, quiet = TRUE)
  current_dir  <- file.path(testDir, paste0(testname, "-current"))
  expected_dir <- file.path(testDir, paste0(testname, "-expected"))
  expected_dir <- paste0(expected_dir, normalize_suffix(suffix))

  # When this function is called from testApp(), this is the way that we get
  # the relative path from the current working dir when testApp() is called.
  # (By the time this function is called, the current working dir is usually set
  # to the test directory.) If the option isn't set, this function was probably
  # called directly (not from testApp()), and we'll just use the value passed
  # in.
  relativeAppDir <- getOption("shinytest.app.dir", default = appDir)

  if (!quiet) {
    message("==== Comparing ", testname, "... ", appendLF = FALSE)
  }

  if (dir_exists(expected_dir)) {

    if (images) {
      filter_fun <- NULL
    } else {
      filter_fun <- remove_image_hashes_json
    }

    res <- dirs_differ(expected_dir, current_dir, filter_fun)

    if (!images) {
      res <- res[!grepl(".*\\.png$", res$name), ]
    }

    # If any files are missing from current or expected, or if they are not
    # identical, then there are differences between the dirs.
    any_different <- any(!res$current | !res$expected | !res$identical)

    if (any_different) {
      snapshot_pass <- FALSE
      snapshot_status <- "different"

      if (!quiet) {
        message("\n  Differences detected between ", basename(current_dir),
                "/ and ", basename(expected_dir), "/:\n")

        # A data frame that shows the differences, just for printed output.
        status <- data.frame(
          Name = res$name,
          " " = "",
          Status = "No change",
          stringsAsFactors = FALSE, check.names = FALSE
        )

        status[[" "]]     [!res$current]  <- "-"
        status[["Status"]][!res$current]  <- "Missing in -current"

        status[[" "]]     [!res$expected] <- "+"
        status[["Status"]][!res$expected] <- "Missing in -expected"

        # Use which() to ignore NA's
        status[[" "]][which(!res$identical)]      <- "!="
        status[["Status"]][which(!res$identical)] <- "Files differ"

        # Add spaces for nicer printed output
        names(status)[names(status) == "Name"] <- "Name     "

        status_table <- utils::capture.output(print(status, row.names = FALSE, right = FALSE))
        status_table <- sub("^", "   ", status_table)

        message(paste(status_table, collapse = "\n"))
      }

      if (interactive) {
        response <- readline("Would you like to view the differences between expected and current results [y/n]? ")
        if (tolower(response) == "y") {
          result <- viewTestDiff(appDir, testname, interactive, suffix = suffix)[[1]]

          if (result == "accept") {
            snapshot_pass <- TRUE
            snapshot_status <- "updated"
            quiet <- TRUE
          }
        }
      }

      if (!quiet && interactive) {

        if (is.null(suffix) || suffix == "") {
          suffix_param <- ""
        } else {
          suffix_param <- paste0(', suffix="', suffix, '"')
        }
        message('\n  To view differences between expected and current results, run:\n',
                '    viewTestDiff("', relativeAppDir, '", "', testname, '"', suffix_param, ')\n',
                '  To save current results as expected results, run:\n',
                '    snapshotUpdate("', relativeAppDir, '", "', testname, '"', suffix_param, ')\n')
      }

    } else {
      if (!quiet) {
        message("No changes.")
      }
      snapshot_pass <- TRUE
      snapshot_status <- "same"
    }

    if (!any_different && autoremove) {
      # If identical contents, remove dir with current results
      unlink(current_dir, recursive = TRUE)
    }

  } else {
    if (!quiet) {
      message("\n  No existing snapshot at '", expected_dir, "/'",
              " This is a first run of tests.\n")
    }

    snapshotUpdate(appDir, testname, quiet = quiet, suffix = suffix)

    snapshot_pass <- TRUE
    snapshot_status <- "new"
  }

  invisible(list(
    appDir = appDir,
    name = testname,
    pass = snapshot_pass,
    status = snapshot_status,
    images = images
  ))
}


#' @rdname snapshotCompare
#' @export
snapshotUpdate <- function(
  appDir = ".",
  testnames = NULL,
  quiet = FALSE,
  suffix = NULL
) {
  testDir <- findTestsDir(appDir, quiet=TRUE)
  if (is.null(testnames)) {
    testnames <- all_testnames(testDir, "-current")
  }

  for (testname in testnames) {
    snapshotUpdateSingle(appDir, testname, quiet, suffix)
  }
}


snapshotUpdateSingle <- function(
  appDir = ".",
  testname,
  quiet = FALSE,
  suffix = NULL
) {
  # Strip off trailing slash if present
  testname <- sub("/$", "", testname)

  testDir <- findTestsDir(appDir, quiet=TRUE)
  base_path <- file.path(testDir, testname)
  current_dir  <- paste0(base_path, "-current")
  expected_dir <- paste0(base_path, "-expected")
  expected_dir <- paste0(expected_dir, normalize_suffix(suffix))

  if (!dir_exists(current_dir)) {
    abort(paste0("Current result directory not found: ", current_dir))
  }

  if (!quiet) {
    message("Updating baseline results at ",  expected_dir, "...")
  }

  if (dir_exists(expected_dir)) {
    if (!quiet)
      message("Removing ", rel_path(expected_dir), ".")
    unlink(expected_dir, recursive = TRUE)
  }

  if (!quiet) {
    message("Renaming ", rel_path(current_dir),
            "\n      => ", rel_path(expected_dir), ".")
  }
  file.rename(current_dir, expected_dir)
  invisible(expected_dir)
}


# Given a JSON string, find any strings that represent base64-encoded images
# and replace them with a hash of the value. The image is base64-decoded and
# then hashed with SHA1. The resulting hash value is the same as if the image
# were saved to a file on disk and then hashed.
hash_snapshot_image_data <- function(data) {

  # Search for base64-encoded image data. There are two named groups:
  # - data_url is the entire data URL, including the leading quote,
  #   "data:image/png;base64,", the base64-encoded data, and the trailing quote.
  # - img_data is just the base64-encoded data.
  image_offsets <- gregexpr(
    '\\n\\s*"[^"]*"\\s*:\\s*(?<data_url>"data:image/[^;]+;base64,(?<img_data>[^"]+)")',
    data,
    perl = TRUE
  )[[1]]

  # No image data found
  if (length(image_offsets) == 1 && image_offsets == -1) {
    return(data)
  }

  attr2 <- function(x, name) {
    attr(x, name, exact = TRUE)
  }

  # Image data indices
  image_start_idx <- as.integer(attr2(image_offsets, "capture.start")[,"img_data"])
  image_stop_idx <- image_start_idx +
    as.integer(attr2(image_offsets, "capture.length")[,"img_data"]) - 1

  # Text (non-image) data indices
  text_start_idx <- c(
    0,
    attr2(image_offsets, "capture.start")[,"data_url"] +
      attr2(image_offsets, "capture.length")[,"data_url"]
  )
  text_stop_idx <- c(
    attr(image_offsets, "capture.start")[,"data_url"] - 1,
    nchar(data)
  )

  # Get the strings representing image data, and all the other stuff
  image_data <- substring(data, image_start_idx, image_stop_idx)
  text_data  <- substring(data, text_start_idx,  text_stop_idx)

  # Hash the images
  image_hashes <- vapply(image_data, FUN.VALUE = "", function(dat) {
    tryCatch({
      image_data <- jsonlite::base64_dec(dat)
      digest::digest(
        image_data,
        algo = "sha1", serialize = FALSE
      )
    }, error = function(e) {
      "Error hashing image data"
    })
  })

  image_hashes <- paste0('"[image data sha1: ', image_hashes, ']"')

  # There's one fewer image hash than text elements. We need to add a blank
  # so that we can properly interleave them.
  image_hashes <- c(image_hashes, "")

  # Interleave the text data and the image hashes
  paste(
    c(rbind(text_data, image_hashes)),
    collapse = ""
  )
}


# Given a JSON string, replace any lines like this:
#   "src": "[image data sha1: ebee9032833ed776d2be63a4c4025961e39d1afe]",
# with this:
#   "src": "[image data]",
remove_image_hashes <- function(json) {
  gsub(
    '((^|\\n)\\s*"src":\\s*"\\[image data) sha1: [^]]+\\]"',
    "\\1]",
    json
  )
}

# Given a filename and contents: if it is a JSON file, remove the image hashes
# and return the new JSON. If it is not a JSON file, return content unchanged.
remove_image_hashes_json <- function(filename, content) {
  if (!grepl("\\.json$", filename))
    return(content)

  content <- raw_to_utf8(content)
  content <- remove_image_hashes(content)
  charToRaw(content)
}

# Given a filename: If it is a PNG file, delete the file. If it is a JSON
# file, remove the image hashes and overwrite the original file with the new
# contents. For all other files, do nothing.
remove_image_hashes_and_files <- function(filename) {
  if (grepl("\\.png$", filename)) {
    unlink(filename)

  } else if (grepl("\\.json$", filename)) {
    content <- read_utf8(filename)
    content <- remove_image_hashes(content)
    write_utf8(content, filename)
    filename
  }

  filename
}