#
# SessionRmdNotebook.R
#
# Copyright (C) 2022 by Posit Software, PBC
#
# Unless you have received this program directly from Posit Software pursuant
# to the terms of a commercial license agreement with Posit Software, then
# this program is licensed to you under the terms of version 3 of the
# GNU Affero General Public License. This program is distributed WITHOUT
# ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING THOSE OF NON-INFRINGEMENT,
# MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Please refer to the
# AGPL (http://www.gnu.org/licenses/agpl-3.0.txt) for more details.
#
#
assign(".rs.notebookVersion", envir = .rs.toolsEnv(), "1.0")

.rs.addFunction("extractRmdFromNotebook", function(notebook) {

   # parse the notebook to get the text of the contained R markdown doc
   parsed <- try(rmarkdown::parse_html_notebook(notebook), silent = TRUE)
   if (inherits(parsed, "try-error") || is.null(parsed$rmd)) {
      return("")
   }

   # as this string will be eventually written to (and compared with) files
   # on disk, use native line endings
   return(paste(parsed$rmd,
                collapse = ifelse(identical(.Platform$OS.type, "windows"),
                                  "\r\n", "\n")))
})

.rs.addFunction("reRmdChunkBegin", function()
{
   "^[\t >]*```+\\s*\\{[.]?([a-zA-Z]+.*)\\}\\s*$"
})

.rs.addFunction("reRmdChunkEnd", function()
{
   "^[\t >]*```+\\s*$"
})

.rs.addFunction("reRmdInlineChunk", function(commentPrefix = "#")
{
   sprintf("^%s\\| .*", commentPrefix)
})


.rs.addFunction("rnb.cachePathFromRmdPath", function(rmdPath)
{
   .Call("rs_chunkCacheFolder", rmdPath)
})

.rs.addFunction("coalesceCsvOutput", function(chunkData) {
   # nothing to coalesce if < 2 outputs
   if (length(chunkData) < 2)
      return(chunkData)

   # keep all output by default
   keep <- rep(TRUE, length(chunkData))

   # coalesce contents for consecutive csv entries
   csvs <- .rs.endsWith(names(chunkData), ".csv")
   for (i in seq.int(1, length(csvs) - 1)) {
      if (keep[[i]] && csvs[[i]] && csvs[[i + 1]]) {
         chunkData[[i]] <- paste(chunkData[[i]], chunkData[[i + 1]], sep = "")
         keep[[i + 1]] <- FALSE
      }
   }
   chunkData[keep]
})

.rs.addFunction("readRnbCache", function(rmdPath, cachePath)
{
   if (!file.exists(rmdPath))
      stop("No file at path '", rmdPath, "'")

   # tolerate missing cache (implies there's no chunk outputs)
   rmdPath <- path.expand(rmdPath)
   rmdContents <- .rs.readLines(rmdPath)

   # Begin collecting the units that form the Rnb data structure
   rnbData <- list()

   # store reference to source path
   rnbData[["source_path"]] <- rmdPath
   rnbData[["cache_path"]]  <- cachePath

   # Keep the original source data
   rnbData[["contents"]] <- rmdContents

   # Set up rnbData structure (if we have a cache, these entries will be filled)
   rnbData[["chunk_info"]] <- list()
   rnbData[["chunk_data"]] <- list()

   # early return if we have no cache
   if (!file.exists(cachePath))
      return(rnbData)

   # Read the chunk information
   chunkInfoPath <- file.path(cachePath, "chunks.json")
   chunkInfo <- .rs.fromJSON(.rs.readFile(chunkInfoPath, encoding = "UTF-8"))
   names(chunkInfo$chunk_definitions) <-
      unlist(lapply(chunkInfo$chunk_definitions, `[[`, "chunk_id"))
   rnbData[["chunk_info"]] <- chunkInfo

   # Read external chunks (code chunks defined in other files)
   rnbData[["external_chunks"]] <- chunkInfo$external_chunks

   # Read the chunk data
   chunkDirs <- file.path(cachePath, names(chunkInfo$chunk_definitions))
   chunkData <- lapply(chunkDirs, function(dir) {
      files <- list.files(dir, full.names = TRUE)

      # exclude directories
      fileInfo <- file.info(files)
      files <- files[!fileInfo$isdir]

      # extract the contents from each regular file
      contents <- lapply(files, function(file) {

         # ignore files that do not have a registered output handler
         ext <- tools::file_ext(file)
         if (!ext %in% names(.rs.rnb.outputHandlers))
            return(NULL)

         # read other files (suppress warnings in case we attempt
         # to read a text file that has NUL bytes and hence is truncated;
         # if those are an issue they'll cause a louder down-stream error)
         suppressWarnings(
            .rs.readFile(
               file     = file,
               encoding = "UTF-8",
               binary   = ext %in% c("webp", "png", "jpg", "jpeg", "rdf")
            )
         )

      })

      names(contents) <- basename(files)
      contents
   })
   names(chunkData) <- basename(chunkDirs)
   rnbData[["chunk_data"]] <- chunkData

   rnbData
})

.rs.addFunction("extractHTMLBodyElement", function(html)
{
   begin <- regexpr('<body[^>]*>', html, perl = TRUE)
   end   <- regexpr('</body>', html, perl = TRUE)

   contents <- substring(html, begin + attr(begin, "match.length"), end - 1)
   .rs.trimWhitespace(contents)
})

.rs.addFunction("rnb.resolveActiveChunkId", function(rnbData, label)
{
   chunkDefns <- rnbData$chunk_info$chunk_definitions
   for (defn in chunkDefns) {
      if (identical(defn$chunk_label, label))
         return(defn$chunk_id)
   }
   return(NULL)
})

.rs.addFunction("rnb.engineToCodeClass", function(engine)
{
   engine <- tolower(engine)
   switch(engine,
          rcpp = "cpp",
          sh = "bash",
          engine)
})

.rs.addFunction("rnb.outputSourcePng", function(fileName,
                                                fileContents,
                                                metadata,
                                                ...)
{
   rmarkdown:::html_notebook_output_png(bytes = fileContents,
                                        meta = metadata)
})

.rs.addFunction("rnb.outputSourceJpeg", function(fileName,
                                                 fileContents,
                                                 metadata,
                                                 ...)
{
   rmarkdown:::html_notebook_output_img(bytes = fileContents,
                                        meta = metadata,
                                        format = "jpeg")
})

.rs.addFunction("rnb.outputSourceConsole", function(fileName,
                                                    fileContents,
                                                    context,
                                                    includeSource,
                                                    ...)
{
   Encoding(fileContents) <- "UTF-8"
   parsed <- .rs.rnb.readConsoleData(fileContents)

   # exclude source code if requested
   if (!includeSource)
      parsed <- parsed[parsed$type != 0, ]

   # exclude console output if requested
   if (identical(context$results, "hide"))
      parsed <- parsed[parsed$type != 1, ]

   attributes <- list(class = .rs.rnb.engineToCodeClass(context$engine))
   rendered <- .rs.rnb.renderConsoleData(parsed,
                                         attributes = attributes,
                                         context)
   return(rendered)
})

.rs.addFunction("rnb.outputSourceHtml", function(fileName,
                                                 fileContents,
                                                 rnbData,
                                                 chunkId,
                                                 metadata,
                                                 ...)
{
   # if we have a '.json' sidecar file, this is an HTML widget
   jsonName <- .rs.withChangedExtension(fileName, ".json")
   jsonPath <- file.path(rnbData$cache_path, chunkId, jsonName)
   if (file.exists(jsonPath)) {

      # read and restore 'html_dependency' class (this may not be
      # preserved in the serialized JSON file)
      jsonContents <- .rs.fromJSON(.rs.readFile(jsonPath, encoding = "UTF-8"))
      for (i in seq_along(jsonContents))
         class(jsonContents[[i]]) <- "html_dependency"

      # extract body element (this is effectively what the
      # widget emitted on print in addition to aforementioned
      # dependency information)
      bodyEl <- .rs.extractHTMLBodyElement(fileContents)

      # annotate widget manually and return asis output
      annotated <- rmarkdown:::html_notebook_annotated_output(
         bodyEl,
         "htmlwidget",
         list(dependencies = jsonContents,
              metadata     = metadata)
      )
      preserved <- htmltools::htmlPreserve(annotated)
      widget <- knitr::asis_output(preserved)
      attr(widget, "knit_meta") <- jsonContents
      return(widget)
   }

   # no .json file; just return HTML as-is
   annotated <- rmarkdown:::html_notebook_annotated_output(
      fileContents,
      "html",
      list(metadata = metadata)
   )
   preserved <- htmltools::htmlPreserve(annotated)
   knitr::asis_output(preserved)
})

.rs.addFunction("rnb.pagedTableHtml", function(rdfPath)
{
   data <- .rs.readDataCapture(rdfPath)

   paste(
      "<div data-pagedtable=\"false\">",
      "  <script data-pagedtable-source type=\"application/json\">",
      jsonlite::toJSON(data),
      "  </script>",
      "</div>",
      sep = "\n"
   )
})

.rs.addFunction("rnb.outputSourceRdf", function(fileName,
                                                fileContents,
                                                metadata,
                                                rnbData,
                                                chunkId,
                                                ...)
{
   rdfName <- .rs.withChangedExtension(fileName, ".rdf")
   rdfPath <- file.path(rnbData$cache_path, chunkId, rdfName)

   annotated <- rmarkdown:::html_notebook_annotated_output(
      .rs.rnb.pagedTableHtml(rdfPath),
      "frame",
      list(metadata = metadata, rdf = .rs.base64encode(fileContents))
   )

   knitr::asis_output(annotated)
})

.rs.addFunction("rnb.outputSource", function(rnbData) {
   force(rnbData)

   # define output source
   result <- function(code, context, ...) {

      # resolve chunk id (attempt to match labels)
      chunkId <- .rs.rnb.resolveActiveChunkId(rnbData, context$label)

      # determine whether we include source code (respect chunk options)
      includeSource <- isTRUE(context$echo) && isTRUE(context$include)

      if (identical(context$engine, "js") || identical(context$engine, "css")) {
         # these engines never show code; ensure they're marked for evaluation
         # and then emit contents literally wrapped in the appropriate tags
         htmlOutput <- ""
         if (isTRUE(context$eval)) {
            if (identical(context$engine, "js")) {
               htmlOutput <- paste(
                  c('<script type="text/javascript">', code, '</script>'),
                  collapse = '\n')
            } else if (identical(context$engine, "css")) {
               htmlOutput <- paste(
                  c('<style type="text/css">', code, '</style>'),
                  collapse = '\n')
            }
         }
         return(knitr::asis_output(htmlOutput))
      } else if (is.null(chunkId)) {
         # if we have no chunk outputs, just show source code (respecting
         # chunk options as appropriate)
         if (includeSource) {
            attributes <- list(class = .rs.rnb.engineToCodeClass(context$engine))

            # tidy code if necessary
            if (isTRUE(context$tidy)) {
               args <- c(list(text = code, output = FALSE), context$tidy.opts)
               formatted <- do.call(formatR::tidy_source, args)
               code <- formatted$text.tidy
            }

            if (!is.null(context$indent)) {
               return(.rs.rnb.renderVerbatimConsoleInput(code, tolower(context$engine), ""))
            } else {
               return(rmarkdown::html_notebook_output_code(code, attributes = attributes))
            }
         }
         return(knitr::asis_output(""))
      }

      chunkData <- .rs.coalesceCsvOutput(rnbData$chunk_data[[chunkId]])

      # map file extensions to handlers
      outputList <- .rs.enumerate(chunkData, function(fileName, fileContents) {

         # read metadata sidecar if present
         metadata <- NULL
         metadataName <- .rs.withChangedExtension(fileName, ".metadata")
         metadataPath <- file.path(rnbData$cache_path, chunkId, metadataName)
         if (file.exists(metadataPath))
            metadata <- .rs.fromJSON(.rs.readFile(metadataPath, encoding = "UTF-8"))

         # find and execute handler for extension (return NULL if no handler defined)
         ext <- tools::file_ext(fileName)
         handler <- .rs.rnb.outputHandlers[[ext]]
         if (!is.function(handler))
            return(NULL)

         handler(code = code,
                 context = context,
                 fileName = fileName,
                 fileContents = fileContents,
                 metadata = metadata,
                 rnbData = rnbData,
                 chunkId = chunkId,
                 includeSource = includeSource)
      })

      # remove nulls
      filtered <- Filter(Negate(is.null), outputList)
      lapply(filtered, function(x) {
         if (!is.list(x)) list(x) else x
      })
   }

   # attach a pre_knit handler that injects setup chunk options
   attr(result, "pre_knit") <- function() {

      # extract setup chunk options
      options <- rnbData$chunk_info$default_chunk_options
      if (is.null(options))
         return()

      # fix up case where 'fig.dim' is a list
      options[["fig.dim"]] <- as.numeric(options[["fig.dim"]])

      # set those options
      knitr::opts_chunk$set(options)

      # return invisibly
      invisible(NULL)
   }

   # return output source
   result
})

.rs.addFunction("createNotebookFromCacheData", function(rnbData,
                                                        inputFile,
                                                        outputFile = NULL,
                                                        envir = .GlobalEnv)
{
   if (is.null(outputFile))
      outputFile <- .rs.withChangedExtension(inputFile, ext = ".nb.html")

   # specify default encoding (we'll try to infer + convert to UTF-8
   # if necessary)
   encoding <- getOption("encoding")

   # attempt to get encoding from source database (note: this will only
   # succeed for files already open in the IDE, but since this operation
   # is normally called when attempting to preview / create a notebook on
   # save we generally expect the document to be available)
   properties <- .rs.getSourceDocumentProperties(inputFile, FALSE)
   if (!is.null(properties$encoding))
      encoding <- properties$encoding

   # reset the knitr chunk counter (it can be modified as a side effect of
   # parse_params, which is called during notebook execution)
   knitr:::chunk_counter(reset = TRUE)

   # restore external chunks into the knit environment
   if (!is.null(rnbData$external_chunks))
      knitr:::knit_code$restore(rnbData$external_chunks)

   # set up output_source
   outputOptions <- list(output_source = .rs.rnb.outputSource(rnbData))

   # override knitr's 'eval_lang' and suppress evaluation of language /
   # symbol chunk options (necessary since we don't actually execute any
   # R code while evaluating chunks and so evaluation of such chunk options
   # could fail)
   if (exists("eval_lang", envir = asNamespace("knitr")))
   {
      override <- function(x, envir = knitr:::knit_global()) {

         # white-list for the commonly-used 'T' and 'F' options
         if (identical(x, as.name("T")))
            return(TRUE)
         else if (identical(x, as.name("F")))
            return(FALSE)
         else if (is.language(x))
            return(NULL)
         else
            return(x)

      }

      original <- .rs.replaceBinding("eval_lang", "knitr", override)
      on.exit(.rs.replaceBinding("eval_lang", "knitr", original), add = TRUE)
   }

   # knitr outputs relevant information in the form of messages that we attach to the error
   renderMessages <- list()
   tryCatch({
      withCallingHandlers({
         # call render with special format hooks
         rmarkdown::render(input = inputFile,
                           output_format = "html_notebook",
                           output_options = outputOptions,
                           output_file = outputFile,
                           quiet = TRUE,
                           envir = envir,
                           encoding = encoding)
      }, message = function(...) {
         args <- list(...)
         renderMessages <<- c(renderMessages, args[[1]])
      })
   }, error = function(e) {
      messages <- list(e$message)

      lapply(renderMessages, function(m) {
         if (typeof(m) != "character") return();

         result <- regexec("Quitting from lines ([0-9]+)-([0-9]+) ", text = m)
         if (result[[1]][[1]] < 0) return();

         groups <- regmatches(m, result)[[1]]
         messages <<- c(messages, paste("See line ", (strtoi(groups[[2]]) - 1), sep = ""))
      })

      stop(paste(messages, collpase = ". ", sep = ""))
   })
})

.rs.addFunction("createNotebookFromCache", function(rmdPath, outputPath = NULL)
{
   # presume success unless we fail below
   result <- list(succeeded = .rs.scalar(TRUE))

   tryCatch({
      cachePath <- .rs.rnb.cachePathFromRmdPath(rmdPath)
      rnbData <- .rs.readRnbCache(rmdPath, cachePath)
      .rs.createNotebookFromCacheData(rnbData, rmdPath, outputPath)
   },

   error = function(e) {
      # convert exception to error message for client
      result <<- list(
         succeeded = .rs.scalar(FALSE),
         error_message = .rs.scalar(e$message)
      )
   })

   result
})

.rs.addFunction("rnb.readConsoleData", function(encodedData)
{
   # read from CSV
   csvData <- read.csv(
      text = encodedData,
      encoding = "UTF-8",
      header = FALSE,
      stringsAsFactors = FALSE
   )

   names(csvData) <- c("type", "text")

   csvData
})

.rs.addFunction("rnb.renderVerbatimConsoleInput", function(code, engine, indent)
{
   Encoding(code) <- "UTF-8"

   if (length(code) == 1)
      code <- strsplit(code, "\n", fixed = TRUE)[[1]]

   # remove indentation from code
   code <- substring(code, nchar(indent) + 1)

   # print as block code (as knitr might normally do)
   fmt <- "```%s\n%s\n```"
   out <- sprintf(fmt, tolower(engine), paste(code, collapse = "\n"))
   knitr::asis_output(out)
})

.rs.addFunction("rnb.renderConsoleData", function(csvData,
                                                  attributes = list(class = "r"),
                                                  context = list())
{
   # bail early for empty data
   if (length(csvData) == 0 || nrow(csvData) == 0)
      return(list())

   # remove ANSI escapes used for color from text
   csvData$text <- gsub("\033\\[\\d*(?:;\\d*)*m", "", csvData$text)

   # split on type
   cutpoints <- .rs.cutpoints(csvData$type)

   ranges <- Map(
      function(start, end) list(start = start, end = end),
      c(1, cutpoints),
      c(cutpoints - 1, nrow(csvData))
   )

   splat <- lapply(ranges, function(range) {
      type <- csvData$type[[range$start]]
      text <- csvData$text[range$start:range$end]
      collapse <- if (type == 0) "\n" else ""
      code <- paste(text, collapse = collapse)

      if (type == 0) {

         # tidy code if necessary
         if (isTRUE(context$tidy)) {
            args <- c(list(text = code, output = FALSE), context$tidy.opts)
            formatted <- do.call(formatR::tidy_source, args)
            code <- paste(formatted$text.tidy, collapse = "\n")
         }

         if (is.null(context$indent)) {
            return(rmarkdown::html_notebook_output_code(code, attributes = attributes))
         } else {
            return(.rs.rnb.renderVerbatimConsoleInput(code, tolower(context$engine), context$indent))
         }
      } else {
         return(code)
      }
   })

   splat
})

.rs.addFunction("scrapeHtmlAttributes", function(line)
{
   reData <- '([[:alnum:]_-]+)[[:space:]]*=[[:space:]]*"(\\\\.|[^"])+"'
   reMatches <- gregexpr(reData, line)[[1]]
   starts <- c(reMatches)
   ends   <- starts + attr(reMatches, "match.length") - 1
   stripped <- substring(line, starts, ends)
   equalsIndex <- regexpr("=", stripped, fixed = TRUE)
   lhs <- substring(stripped, 1, equalsIndex - 1)
   rhs <- substring(stripped, equalsIndex + 2, nchar(stripped) - 1)
   names(rhs) <- lhs
   as.list(rhs)
})

.rs.addFunction("rnb.encode", function(data)
{
   .rs.base64encode(.rs.toJSON(data, unbox = TRUE))
})

.rs.addFunction("rnb.decode", function(encoded)
{
   .rs.fromJSON(.rs.base64decode(encoded))
})


.rs.addFunction("parseInlineChunkImpl", function(opt)
{
   # read as YAML
   opts <- .rs.fromYAML(opt)

   # knitr version 1.44 introduced a function `knitr:::dot_names`
   # which converts dashes to dots in chunk options
   knitr <- asNamespace("knitr")
   if (is.function(knitr$dot_names))
   {
      opts <- knitr$dot_names(opts)
   }
   else
   {
      names(opts) <- gsub("-", ".", names(opts))
   }
   # parse truthy and falsy style yaml options
   opts <- lapply(opts, function(value)
   {
      if (!is.character(value))
         return(value)
      if (tolower(value) %in% c("y", "yes", "on"))
         return(TRUE)
      if (tolower(value) %in% c("n", "no", "off"))
         return(FALSE)
      else
         return(value)
   })

   opts
})

.rs.addFunction("parseInlineChunk", function(opt, commentPrefix = "#")
{
   # remove comment prefix
   commentPrefixPattern <- sprintf("^%s\\|\\s+", commentPrefix)
   opt <- sub(commentPrefixPattern, "", opt)

   # check for YAML entry, mimicking code in knitr;
   # otherwise, parse the code as R code (comma-separated, tag=value style options)
   if (grepl("^[^ :]+:($|\\s)", opt[[1]])) {
      tryCatch(
         .rs.parseInlineChunkImpl(opt),
         error = function(cnd) list()
      )
   } else {
      opts <- paste(opt, collapse = " ")
      knitr:::parse_params(opts, label = FALSE)
   }
})

.rs.addFunction("evaluateChunkOptions", function(id, type, code)
{
   Encoding(code) <- "UTF-8"
   code <- unlist(strsplit(code, "\n", fixed = TRUE))

   # parsed chunk options; start with default chunk options
   opts <- list()

   # first, parse chunk options embedded in the chunk header
   rmdChunkOpts <- code[[1]]

   # strip chunk indicators if present
   matches <- unlist(regmatches(rmdChunkOpts, regexec(.rs.reRmdChunkBegin(), rmdChunkOpts)))
   if (length(matches) > 1)
      rmdChunkOpts <- matches[[2]]

   # attempt to parse parameters (swallow errors)
   .rs.tryCatch({

      # extract and remove engine name (can be overridden below with engine=)
      opts$engine <- unlist(strsplit(rmdChunkOpts, split = "(\\s|,)+"))[[1]]
      rmdChunkOpts <- substring(rmdChunkOpts, nchar(opts$engine) + 1)

      # parse them, then merge with the defaults (evaluate in global environment)
      parsedParams <- eval(
         substitute(knitr:::parse_params(rmdChunkOpts)),
         envir = .GlobalEnv
      )

      # merge options together
      opts <- .rs.mergeLists(opts, parsedParams)

      # if this is the setup chunk, it's not included by default
      if (identical(opts$label, "setup") && is.null(opts$include))
         opts$include <- FALSE

      # if a chunk option is provided in both body (yaml chunk options) and header (rmdChunkOpts)
      # the body should override the header option
      opts <- opts[unique(names(opts))]

      # convert T, F for R code chunk options to TRUE, FALSE as appropriate
      opts <- lapply(opts, function(opt) {
         if (identical(opt, as.name("T")))
            TRUE
         else if (identical(opt, as.name("F")))
            FALSE
         else
            opt
      })

      # convert language name objects to plain characters (these can occur in
      # malformed expressions, and cause scalar conversion below to fail)
      names <- vapply(opts, is.name, TRUE)
      opts[names] <- as.character(opts[names])

   })

   # now, try to find inline chunk options
   inlineChunkOptions <- c()

   # figure out the appropriate chunk prefix based on the engine
   engine <- tolower(.rs.nullCoalesce(opts$engine, "r"))
   commentPrefix <- if (engine %in% c("cc", "cpp", "go", "js", "node", "rcpp", "stan"))
      "//"
   else if (engine %in% c("haskell", "sql"))
      "--"
   else
      "#"

   reCommentPrefix <- .rs.reRmdInlineChunk(commentPrefix)
   for (line in code[-1]) {
      # there may be variable number of in-body chunk opts,
      # but they should all be at the top of the chunk
      match <- unlist(regmatches(line, regexec(reCommentPrefix, line)))
      if (length(match) == 0 && commentPrefix != "#")
      {
         # if the language-specific comment prefix character was not used,
         # fallback and check for starting with #| instead before bailing
         match <- unlist(regmatches(line, regexec(.rs.reRmdInlineChunk("#"), line)))
         if (length(match) == 0)
            break
         # if we found a match, we also need to update what gets passed to .rs.parseInlineChunk
         commentPrefix <- "#"
         reCommentPrefix <- .rs.reRmdInlineChunk(commentPrefix)
      }
      else if (length(match) == 0)
         break
      # add the line
      inlineChunkOptions <- c(inlineChunkOptions, match)
   }

   # if we had some YAML chunk options, try to add them
   if (length(inlineChunkOptions) > 0)
   {
      tryCatch({
         inlineOpts <- .rs.parseInlineChunk(inlineChunkOptions, commentPrefix)
         opts <- .rs.mergeLists(opts, inlineOpts)
      }, error = function(e) {
         warning("Failed to parse chunk options in body:\n", e)
      })
   }

   # ensure that fields we expect to be logical are actually logical
   # (sanitize invalid inputs here since they can break notebook execution)
   fields <- list(
      warning = TRUE,
      message = TRUE,
      error   = FALSE
   )

   .rs.enumerate(fields, function(key, default) {

      if (is.null(opts[[key]]))
         return()

      opts[[key]] <<- tryCatch(
         as.logical(opts[[key]]),
         error = function(e) default
      )

   })

   # if this is a SQL chunk, try to provide a default connection
   # TODO: arguably, we should be using `knitr::opts_chunk$get()`
   # to provide defaults for chunk options, but it's not clear if
   # that's always the correct choice, so we just make the smaller
   # piece-meal decision here
   if (opts$engine %in% c("mysql", "psql", "sql")) {

      # get current connection
      conn <- .rs.nullCoalesce(
         opts$connection,
         knitr::opts_chunk$get("connection")
      )

      # our chunk execution tools expect connection to be a character naming a variable in the environment
      # if conn is provided as a symbol, pass connection the actual variable name
      # if conn is provided as a DB connection, use a temporary variable
      # to store the connection value and pass the temp variable name
      if (!is.null(conn) && !is.character(conn)) {
         if (is.name(conn)) {
            opts$connection <- as.character(conn)
         } else {
            .rs.setVar("chunkConnection", conn)
            opts$connection <- ".rs.chunkConnection"
         }
      }

   }

   # knitr sets a default fig.ext of 'png', so we'll set that too
   # this is necessary for some engines, e.g. dot
   # https://github.com/rstudio/rstudio/issues/13187
   opts$dev <- .rs.nullCoalesce(opts$dev, "png")

   .rs.scalarListFromList(opts, expressions = TRUE)
})

.rs.addFunction("extractChunkInnerCode", function(code)
{
   # split into lines
   Encoding(code) <- "UTF-8"
   code <- unlist(strsplit(code, "\n", fixed = TRUE))

   # find chunk indicators (safe fallbacks if absent)
   start <- max(1, grep(.rs.reRmdChunkBegin(), code, perl = TRUE))
   end   <- min(length(code), grep(.rs.reRmdChunkEnd(), code, perl = TRUE))

   code <- code[(start + 1):(end - 1)]
   code <- gsub("#[|].*$", "", code)

   paste(code, collapse = "\n")
})

.rs.addFunction("extractRmdChunkInformation", function(rmd)
{
   starts <- grep(.rs.reRmdChunkBegin(), rmd, perl = TRUE)
   ends   <- grep(.rs.reRmdChunkEnd(), rmd, perl = TRUE)

   # TODO: how to handle invalid document?
   n <- min(length(starts), length(ends))
   if (length(starts) != n) starts <- starts[seq_len(n)]
   if (length(ends) != n)   ends <- ends[seq_len(n)]

   # collect chunk information
   lapply(seq_len(n), function(i) {
      begin    <- starts[[i]]
      end      <- ends[[i]]
      contents <- rmd[begin:end]
      list(
         begin    = starts[[i]],
         end      = ends[[i]],
         contents = contents
      )
   })
})

.rs.addFunction("rnb.generateRandomChunkId", function()
{
   candidates <- c(letters, 0:9)
   .rs.randomString("c", candidates = candidates, n = 12L)
})

.rs.addFunction("hydrateCacheFromNotebook", function(nbPath, cachePath = NULL)
{
   if (is.null(cachePath)) {
      rmdPath <- .rs.withChangedExtension(nbPath, ".Rmd")
      cachePath <- .rs.rnb.cachePathFromRmdPath(rmdPath)
   }

   # ensure cache directory
   if (!.rs.dirExists(cachePath))
      dir.create(cachePath, recursive = TRUE)

   # parse the notebook file
   nbData <- rmarkdown::parse_html_notebook(nbPath)

   # clear out old cache
   unlink(list.files(cachePath, full.names = TRUE), recursive = TRUE)

   # State, etc. ----
   lastActiveAnnotation   <- list()
   activeChunkId          <- "unknown"
   activeChunkIndex       <- 0
   activeIndex            <- 2

   headerContent <- nbData$source[`:`(
      grep("^\\s*<head>\\s*$", nbData$source, perl = TRUE)[[1]] + 1,
      grep("^\\s*</head>\\s*$", nbData$source, perl = TRUE)[[1]] - 1
   )]

   chunkInfo <- .rs.extractRmdChunkInformation(nbData$rmd)

   outputPath <- function(cachePath, chunkId, index, ext) {
      file.path(cachePath, chunkId, sprintf("%06i.%s", as.integer(index), ext))
   }

   # Text ----
   onText <- function(annotation) {
      # HACK: the 'chunk' hook is not fired for chunks that
      # produce no output on execution, and so such chunks
      # are not annotated within the generated .nb.html file.
      # fortunately, we can detect two sequential 'text'
      # blocks as an indicator that there was an 'invisible'
      # chunk within.
      if (identical(annotation$state, "begin") &&
          identical(lastActiveAnnotation$label, "text") &&
          identical(lastActiveAnnotation$state, "end"))
      {
         activeChunkId    <<- .rs.rnb.generateRandomChunkId()
         activeChunkIndex <<- activeChunkIndex + 1
         activeIndex      <<- 2
      }
   }

   # Console I/O ----
   consoleDataBuilder <- .rs.listBuilder()
   writeConsoleData <- function(builder) {
      if (builder$empty()) return()

      # convert to .csv file
      df <- .rs.rbindList(builder$data())

      # reorder and rename type column
      df <- df[c("type", "data")]
      df$type[df$type == "input"]  <- "0"
      df$type[df$type == "output"] <- "1"

      path <- outputPath(cachePath, activeChunkId, activeIndex, "csv")
      .rs.ensureDirectory(dirname(path))
      write.table(df,
                  file = path,
                  quote = TRUE,
                  sep = ",",
                  row.names = FALSE,
                  col.names = FALSE,
                  fileEncoding = "UTF-8")

      # update state
      builder$clear()
      activeIndex <<- activeIndex + 1
   }

   onSource <- function(annotation) {
      if (annotation$state == "begin") {
         consoleDataBuilder$append(list(
            data = paste(annotation$meta$data, collapse = "\n"),
            type = "input"
         ))
      } else {
         # nothing to do?
      }
   }

   onOutput <- function(annotation) {
      if (annotation$state == "begin") {
         consoleDataBuilder$append(list(
            data = paste(annotation$meta$data, collapse = "\n"),
            type = "output"
         ))
      } else {
         # nothing to do?
      }
   }

   # Chunk Handling ----
   chunkDefnsBuilder <- .rs.listBuilder()
   onChunk <- function(annotation) {
      if (annotation$state == "begin") {

         # update state re: active chunk + number of processed outputs
         activeChunkIndex <<- activeChunkIndex + 1
         activeIndex      <<- 2

         # create chunk defn for this chunk
         info <- chunkInfo[[activeChunkIndex]]

         # get active chunk id (special handling for setup chunk)
         candidates <- c(letters, 0:9)
         if (.rs.isSetupChunk(info$contents))
            activeChunkId <<- "csetup_chunk"
         else
            activeChunkId <<- .rs.rnb.generateRandomChunkId()

         # add our chunk defn
         chunkDefnsBuilder$append(list(
            chunk_id = activeChunkId,
            expansion_state = 0,
            options = list(),         # TODO: parse from chunk header?
            row = info$end - 1,
            row_count = 1,            # TODO: ever not 1?
            visible = TRUE
         ))

      } else {
         # flush console data
         writeConsoleData(consoleDataBuilder)

         # leaving active chunk
         activeChunkId <<- "unknown"
      }
   }

   # Plot Handling ----
   plotRange <- list(start = NULL, end = NULL)
   plotMeta <- NULL
   writePlot <- function(source, range, meta) {

      # get html plot output
      html <- paste(source[`:`(
         range$start + 1,
         range$end - 1
      )], collapse = " ")

      # extract base64 encoded content
      scraped <- .rs.scrapeHtmlAttributes(html)
      ext <- if (.rs.startsWith(scraped$src, "data:image/jpeg;"))
         "jpeg" else "png"
      imgDataEncoded <- substring(scraped$src,
                                  nchar(paste("data:image/", ext, ";base64,", sep = "")) + 1)
      imgData <- .rs.base64decode(imgDataEncoded, binary = TRUE)

      # write to file
      path <- outputPath(cachePath, activeChunkId, activeIndex, ext)
      .rs.ensureDirectory(dirname(path))
      writeBin(imgData, path, useBytes = TRUE)

      # write metadata if present
      if (!is.null(meta) && !is.null(meta$metadata)) {
         metaPath <- outputPath(cachePath, activeChunkId, activeIndex, "metadata")
         cat(.rs.toJSON(meta, unbox = TRUE), file = metaPath, sep = "\n")
      }

      # update state
      activeIndex <<- activeIndex + 1
   }
   onPlot <- function(annotation) {
      if (annotation$state == "begin") {
         writeConsoleData(consoleDataBuilder)
         plotRange$start <<- annotation$row
         plotMeta        <<- annotation$meta
      } else {
         plotRange$end <<- annotation$row
         writePlot(nbData$source, plotRange, plotMeta)
         plotRange <<- list(start = NULL, end = NULL)
         plotMeta  <<- NULL
      }
   }

   # Data frame handling ----
   frameRange <- list(start = NULL, end = NULL)
   frameMeta <- NULL
   writeFrame <- function(source, range, meta) {
      if (is.null(meta))
         return(NULL);

      # write out frame metadata
      if (!is.null(meta$metadata)) {
         metaPath <- outputPath(cachePath, activeChunkId, activeIndex, "metadata")
         cat(.rs.toJSON(meta$metadata, unbox = TRUE), file = metaPath, sep = "\n")
      }

      # write out raw frame data
      if (!is.null(meta$rdf)) {
         rdfPath <- outputPath(cachePath, activeChunkId, activeIndex, "rdf")
         writeBin(object = .rs.base64decode(meta$rdf, binary = TRUE),
                  con = rdfPath)
      }
   }
   onFrame <- function(annotation) {
      if (annotation$state == "begin") {
         writeConsoleData(consoleDataBuilder)
         frameRange$start <<- annotation$row
         frameMeta        <<- annotation$meta
      } else {
         frameRange$end <<- annotation$row
         writeFrame(nbData$source, frameRange, frameMeta)
         frameRange <<- list(start = NULL, end = NULL)
         frameMeta  <<- NULL
      }
   }

   # HTML Handling ----
   htmlRange <- list(start = NULL, end = NULL)
   htmlMeta <- NULL
   writeHtml <- function(source, range, meta) {

      # extract html from source document
      htmlOutput <- source[`:`(
         range$start + 1,
         range$end - 1
      )]

      htmlPath <- outputPath(cachePath, activeChunkId, activeIndex, "html")
      cat(htmlOutput, file = htmlPath, sep = "\n")

      # write metadata if present
      if (!is.null(meta) && !is.null(meta$metadata)) {
         metaPath <- outputPath(cachePath, activeChunkId, activeIndex, "metadata")
         cat(.rs.toJSON(meta, unbox = TRUE), file = metaPath, sep = "\n")
      }

      # update state
      activeIndex <<- activeIndex + 1
   }
   onHtml <- function(annotation) {
      if (annotation$state == "begin") {
         writeConsoleData(consoleDataBuilder)
         htmlRange$start <<- annotation$row
         htmlMeta        <<- annotation$meta
      } else {
         htmlRange$end   <<- annotation$row
         writeHtml(nbData$source, htmlRange, htmlMeta)
         htmlRange <<- list(start = NULL, end = NULL)
         htmlMeta  <<- NULL
      }
   }

   # HTML Widget Handling ----
   widgetRange <- list(start = NULL, end = NULL)
   widgetMeta  <- NULL
   writeHtmlWidget <- function(source, range, meta) {

      # get inner (body) HTML
      htmlBody <- source[`:`(
         range$start + 1,
         range$end - 1
      )]

      # TODO: background color should be passed as
      # metadata attribute and used here
      fmt <- paste(
         '<!DOCTYPE html>',
         '<html>',
         '<head>',
         '%s',
         '</head>',
         '<body style="background-color:white;">',
         '%s',
         '</body>',
         '</html>',
         sep = "\n"
      )

      htmlOutput <- sprintf(fmt,
                            paste(headerContent, collapse = "\n"),
                            paste(htmlBody, collapse = "\n"))

      htmlPath <- outputPath(cachePath, activeChunkId, activeIndex, "html")
      cat(htmlOutput, file = htmlPath, sep = "\n")

      jsonPath <- outputPath(cachePath, activeChunkId, activeIndex, "json")
      cat(.rs.toJSON(meta, unbox = TRUE), file = jsonPath, sep = "\n")

      # update state
      activeIndex <<- activeIndex + 1
   }
   onHtmlWidget <- function(annotation) {
      if (annotation$state == "begin") {
         writeConsoleData(consoleDataBuilder)
         widgetRange$start <<- annotation$row
         widgetMeta        <<- annotation$meta
      } else {
         widgetRange$end <- annotation$row
         writeHtmlWidget(nbData$source, widgetRange, widgetMeta)
         widgetRange <<- list(start = NULL, end = NULL)
         widgetMeta  <<- NULL
      }
   }

   # begin looping through annotations and building cache
   annotations <- nbData$annotations
   for (i in seq_along(annotations)) {

      annotation <- annotations[[i]]
      label <- annotation$label

      switch(label,
             "text"       = onText(annotation),
             "chunk"      = onChunk(annotation),
             "source"     = onSource(annotation),
             "output"     = onOutput(annotation),
             "plot"       = onPlot(annotation),
             "html"       = onHtml(annotation),
             "frame"      = onFrame(annotation),
             "htmlwidget" = onHtmlWidget(annotation))

      lastActiveAnnotation <- annotation
   }

   # write 'chunks.json' based on gathered chunk info
   mtime <- file.info(nbPath)$mtime
   chunks <- list(
      chunk_definitions = chunkDefnsBuilder$data(),
      doc_write_time    = as.numeric(mtime)
   )
   chunksJson <- .rs.toJSON(chunks, unbox = TRUE)
   chunksJsonPath <- file.path(cachePath, "chunks.json")
   cat(chunksJson, file = chunksJsonPath, sep = "\n")

   # NOTE: we don't bother writing a libs folder as we'll just dump
   # the base64 encoded headers into all HTML widget elements

})

.rs.addFunction("isSetupChunk", function(lines)
{
   if (!is.character(lines) || !length(lines))
      return(FALSE)

   grepl("^\\s*```{[Rr]\\s+setup[\\s,}]", lines[[1]], perl = TRUE)
})

.rs.addFunction("setDefaultChunkOptions", function()
{
   # get the current set of chunk options
   chunkOptions <- knitr::opts_chunk$get()

   # make sure global connection lists exists
   if (!exists(".rs.knitr.chunkReferences", envir = .rs.toolsEnv()))
      assign(".rs.knitr.chunkReferences", list(), envir = .rs.toolsEnv())

   # assign connection
   chunkReferences <- get(".rs.knitr.chunkReferences", envir = .rs.toolsEnv())
   if (!is.null(chunkOptions$connection) && !is.character(chunkOptions$connection)) {
      idReference <- length(chunkReferences) + 1
      chunkReferences[[idReference]] <- chunkOptions$connection
      chunkOptions$connection <- idReference
   }

   # cache the current set of chunk options
   assign(".rs.knitr.chunkOptions", chunkOptions, envir = .rs.toolsEnv())

   # cache the set of external code
   knitrCode <- knitr:::knit_code$get()
   assign(".rs.knitr.code", knitrCode, envir = .rs.toolsEnv())

   # cache default working dir
   knitrDir <- knitr::opts_knit$get("root.dir")
   assign(".rs.knitr.root.dir", knitrDir, envir = .rs.toolsEnv())

   # unset the chunk options and code (so we know what options/code
   # were actually specified in setup chunk later)
   # (we tag the 'FALSE' value so we can detect if the user has explicitly
   # set or unset it in the setup chunk as well)
   defaults <- list(error = .rs.scalar(FALSE))
   knitr::opts_chunk$restore(defaults)
   knitr:::knit_code$restore(list())
   knitr::opts_knit$set(root.dir = NULL)
})

.rs.addFunction("defaultChunkOptions", function()
{
   # get current set of options
   defaultOptions <- knitr::opts_chunk$get()

   # remove the rstudio-injected 'error' option if needed
   if (identical(defaultOptions$error, .rs.scalar(FALSE)))
      defaultOptions$error <- NULL

   # restore the previously cached knitr options and code
   chunkOptions <- get(".rs.knitr.chunkOptions", envir = .rs.toolsEnv())
   knitr::opts_chunk$restore(chunkOptions)
   knitrCode <- get(".rs.knitr.code", envir = .rs.toolsEnv())
   knitr:::knit_code$restore(knitrCode)
   knitrDir <- get(".rs.knitr.root.dir", envir = .rs.toolsEnv())
   knitr::opts_knit$set(root.dir = knitrDir)

   # overlay any newly-set chunk options set by the user in this chunk.
   # this is necessary so that settings from e.g.
   #
   #    knitr::opts_chunk$set(connection = conn)
   #
   # are appropriately preserved after running the setup chunk
   knitr::opts_chunk$set(defaultOptions)

   # return current set
   .rs.scalarListFromList(defaultOptions)
})

.rs.addFunction("executeChunkCallback", function(chunkName, chunkCode)
{
   if (exists(".rs.notebookChunkCallbacks", envir = .rs.toolsEnv()) &&
       length(.rs.notebookChunkCallbacks) != 0)
   {
      handle <- ls(envir = .rs.notebookChunkCallbacks)
      chunkCallback <- get(handle, envir = .rs.notebookChunkCallbacks)
      return(chunkCallback(eval(chunkName), eval(chunkCode)))
   }
   NULL
})

# a list mapping file extensions to its associated output handler
.rs.setVar("rnb.outputHandlers", list(
   "png"  = .rs.rnb.outputSourcePng,
   "jpg"  = .rs.rnb.outputSourceJpeg,
   "jpeg" = .rs.rnb.outputSourceJpeg,
   "csv"  = .rs.rnb.outputSourceConsole,
   "html" = .rs.rnb.outputSourceHtml,
   "rdf"  = .rs.rnb.outputSourceRdf
))
