1#
2# SessionRMarkdown.R
3#
4# Copyright (C) 2021 by RStudio, PBC
5#
6# Unless you have received this program directly from RStudio pursuant
7# to the terms of a commercial license agreement with RStudio, then
8# this program is licensed to you under the terms of version 3 of the
9# GNU Affero General Public License. This program is distributed WITHOUT
10# ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING THOSE OF NON-INFRINGEMENT,
11# MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Please refer to the
12# AGPL (http://www.gnu.org/licenses/agpl-3.0.txt) for more details.
13#
14#
15
16.rs.setVar("markdown.acCompletionTypes", list(
17   COMPLETION_HREF = 1
18))
19
20.rs.addJsonRpcHandler("markdown_get_completions", function(type, data)
21{
22   if (type == .rs.markdown.acCompletionTypes$COMPLETION_HREF)
23      return(.rs.markdown.getCompletionsHref(data))
24})
25
26.rs.addFunction("markdown.resolveCompletionRoot", function(path)
27{
28   # figure out working directory
29   props <- .rs.getSourceDocumentProperties(path)
30   workingDirProp <- props$properties$working_dir
31
32   useProject <-
33      identical(workingDirProp, "project") &&
34      is.character(props$path) &&
35      is.character(props$project_path)
36
37   if (useProject)
38   {
39      # path refers to the full path; project_path refers
40      # to the project-relative path. use that to infer
41      # the path to the project hosting the document
42      # (just in case the user is editing a document that
43      # belongs to an alternate project)
44      substring(props$path, 1L, nchar(props$path) - nchar(props$project_path) - 1L)
45   }
46   else if (identical(workingDirProp, "current"))
47   {
48      getwd()
49   }
50   else
51   {
52      dirname(path)
53   }
54})
55
56.rs.addFunction("markdown.getCompletionsHref", function(data)
57{
58   # extract parameters
59   token <- data$token
60   path <- data$path
61
62   # if we don't have a path, bail
63   if (is.null(path))
64      return(.rs.emptyCompletions())
65
66   # figure out working directory
67   workingDir <- .rs.markdown.resolveCompletionRoot(path)
68
69   # determine dirname, basename (need to handle trailing slashes properly
70   # so can't just use dirname / basename)
71   slashes <- gregexpr("[/\\]", token)[[1]]
72   idx <- tail(slashes, n = 1)
73   lhs <- substring(token, 1, idx - 1)
74   rhs <- substring(token, idx + 1)
75
76   # check to see if user is providing absolute path, and construct
77   # completion directory appropriately
78   isAbsolute <- grepl("^(?:[A-Z]:|/|\\\\|~)", token, perl = TRUE)
79   if (!isAbsolute)
80      lhs <- file.path(workingDir, lhs)
81
82   # retrieve completions
83   completions <- .rs.getCompletionsFile(
84      token = rhs,
85      path = lhs,
86      quote = FALSE,
87      directoriesOnly = FALSE
88   )
89
90   return(completions)
91
92})
93
94.rs.addFunction("scalarListFromList", function(l, expressions = FALSE)
95{
96   # hint that every non-list element of the hierarchical list l
97   # is a scalar value if it is of length 1
98   l <- lapply(l, function(ele) {
99      if (is.null(ele))
100         NULL
101      else if (is.list(ele))
102         .rs.scalarListFromList(ele)
103      else if (length(ele) == 1) {
104         # mark strings with encoding unless already marked (see comment
105         # below in convert_to_yaml)
106         if (is.character(ele) && Encoding(ele) == "unknown")
107            Encoding(ele) <- "UTF-8"
108         .rs.scalar(ele)
109      }
110      else if (identical(expressions, TRUE) && (is.expression(ele) || is.call(ele)))
111         .rs.scalarListFromList(list(expr = eval(ele)))$expr
112      else
113         ele
114   })
115})
116
117.rs.addFunction("isREADME", function(file) {
118  identical(tools::file_path_sans_ext(basename(file)), "README")
119})
120
121.rs.addFunction("updateRMarkdownPackage", function(archive)
122{
123  pkgDir <- find.package("rmarkdown")
124  .rs.forceUnloadPackage("rmarkdown")
125  .Call("rs_installPackage",  archive, dirname(pkgDir))
126})
127
128.rs.addFunction("getRmdRuntime", function(file) {
129   lines <- readLines(file, warn = FALSE)
130
131   yamlFrontMatter <- tryCatch(
132     rmarkdown:::parse_yaml_front_matter(lines),
133     error=function(e) {
134        list()
135     })
136
137   if (!is.null(yamlFrontMatter$runtime))
138      yamlFrontMatter$runtime
139    else
140      ""
141})
142
143.rs.addFunction("getCustomRenderFunction", function(file) {
144  # read the contents of the file
145  lines <- readLines(file, warn = FALSE)
146
147  # mark the encoding if it's available
148  properties <- .rs.getSourceDocumentProperties(file)
149  if (identical(properties$encoding, "UTF-8"))
150    Encoding(lines) <- "UTF-8"
151
152  yamlFrontMatter <- tryCatch(
153    rmarkdown:::parse_yaml_front_matter(lines),
154    error = function(e) {
155      list()
156    }
157  )
158
159  haveQuarto <- function() {
160    nzchar(Sys.which("quarto"))
161  }
162
163  isQuartoDoc <- function() {
164     # .qmd file
165     .rs.endsWith(file, ".qmd") ||
166     # file with "format" yaml and no "output" yaml
167     (is.null(yamlFrontMatter[["output"]]) && !is.null(yamlFrontMatter[["format"]])) ||
168     # quarto extended type
169     identical(.Call("rs_detectExtendedType", file), "quarto-document") ||
170     # plain markdown file w/ "jupyter" metdata
171     (.rs.endsWith(file, ".md") && !is.null(yamlFrontMatter[["jupyter"]]))
172  }
173
174  if (is.character(yamlFrontMatter[["knit"]]))
175    yamlFrontMatter[["knit"]][[1]]
176  else if (haveQuarto() && isQuartoDoc())
177     "quarto render"
178  else if (!is.null(yamlFrontMatter$runtime) &&
179           grepl('^shiny', yamlFrontMatter$runtime)) {
180    # use run as a wrapper for render when the doc requires the Shiny runtime,
181    # and outputs HTML.
182    tryCatch({
183       outputFormat <- rmarkdown:::output_format_from_yaml_front_matter(lines)
184       formatFunction <- eval(parse(text = outputFormat$name),
185                              envir = asNamespace("rmarkdown"))
186       if (identical(tolower(tools::file_ext(
187            rmarkdown:::pandoc_output_file("shiny", formatFunction()$pandoc))),
188            "html"))
189          "rmarkdown::run"
190       else
191          # this situation is nonsensical (runtime: shiny only makse sense for
192          # HTML-based output formats)
193          ""
194     }, error = function(e) {
195        ""
196     })
197  }
198  else {
199    # return render_site if we are in a website and this isn't a README
200    if (!.rs.isREADME(file)) {
201       siteGenerator <- tryCatch(rmarkdown::site_generator(file),
202                                 error = function(e) NULL)
203       if (!is.null(siteGenerator))
204         "rmarkdown::render_site"
205       else
206         ""
207    }
208    else {
209       ""
210    }
211  }
212})
213
214# given an input file, return the associated output file, and attempt to deduce
215# whether it's up to date (e.g. for input.Rmd producing input.html, see whether
216# input.html exists and has been written since input.Rmd)
217.rs.addFunction("getRmdOutputInfo", function(target) {
218
219   # read the contents of the file
220   lines <- readLines(target, warn = FALSE)
221
222   # mark the encoding if it's available
223   properties <- .rs.getSourceDocumentProperties(target)
224   if (identical(properties$encoding, "UTF-8"))
225      Encoding(lines) <- "UTF-8"
226
227   # compute the name of the output file
228   outputFormat <- rmarkdown:::output_format_from_yaml_front_matter(lines)
229   outputFormat <- rmarkdown:::create_output_format(outputFormat$name, outputFormat$options)
230   outputFile <- rmarkdown:::pandoc_output_file(target, outputFormat$pandoc)
231
232   # determine location of output file, accounting for possibility of a website project which
233   # puts the output in a different location than the source file
234   outputDir <- .Call("rs_getWebsiteOutputDir")
235   if (is.null(outputDir))
236      outputDir <- dirname(target)
237   outputPath <- file.path(outputDir, outputFile)
238
239   # ensure output file exists
240   fileExists <- file.exists(outputPath)
241   current <- fileExists &&
242      file.info(outputPath)$mtime >= file.info(target)$mtime
243
244   # return named list and alias paths (this data goes to the client)
245   list(
246      output_file = .rs.scalar(.rs.createAliasedPath(outputPath)),
247      is_current  = .rs.scalar(current),
248      output_file_exists = .rs.scalar(fileExists)
249   )
250})
251
252.rs.addFunction("getTemplateDetails", function(templateYaml) {
253   yaml::yaml.load_file(templateYaml)
254})
255
256# given a path to a folder on disk, return information about the R Markdown
257# template in that folder.
258.rs.addFunction("getTemplateYamlFile", function(path)
259{
260   # check for required files
261   templateYaml <- file.path(path, "template.yaml")
262   skeletonPath <- file.path(path, "skeleton")
263   if (!file.exists(templateYaml)) {
264      templateYaml <- file.path(path, "template.yml")
265      if (!file.exists(templateYaml))
266         return(NULL)
267   }
268
269   # validate that a skeleton.Rmd file exists
270   paths <- file.path(skeletonPath, c("skeleton.rmd", "skeleton.Rmd"))
271   if (!any(file.exists(paths)))
272      return(NULL)
273
274   # will need to enforce create_dir if there are multiple files in /skeleton/
275   multiFile <- length(list.files(skeletonPath)) > 1
276
277   # return metadata; we won't parse until the client requests template files
278   list(
279      template_yaml = .rs.scalar(templateYaml),
280      multi_file    = .rs.scalar(multiFile)
281   )
282})
283
284.rs.addFunction("evaluateRmdParams", function(contents) {
285
286   Encoding(contents) <- "UTF-8"
287
288   # extract the params using knitr::knit_params
289   knitParams <- knitr::knit_params(contents)
290
291   if (length(knitParams) > 0)
292   {
293      # turn them into a named list
294      params <- list()
295      for (param in knitParams)
296         params[[param$name]] <- param$value
297
298      # mark as knit_params_list (so other routines know we generated it)
299      class(params) <- "knit_param_list"
300
301      # inject into global environment
302      assign("params", params, envir = globalenv())
303   }
304})
305
306.rs.addJsonRpcHandler("convert_to_yaml", function(input)
307{
308   # the yaml package doesn't treat string values kindly if they're surrounded
309   # by backticks, so we will need to replace those with UUIDs we can sub out
310   # later
311   exprs <- list()
312   tick_sub <- function(x)
313   {
314      lapply(x, function(val)
315      {
316         if (is.list(val))
317         {
318            # if it's a list, recurse
319            tick_sub(val)
320         }
321         else if (is.character(val) && length(val) == 1)
322         {
323            needsPlaceholder <- (function() {
324
325               # if it's a character value, check to see if it's a backtick
326               # expression
327               if (identical(substr(val, 1, 1), "`") &&
328                   identical(substr(val, nchar(val), nchar(val)), "`"))
329               {
330                  return(TRUE)
331               }
332
333               # if it's a tagged value, placeholder
334               if (grepl("^[!]", val))
335                  return(TRUE)
336
337               FALSE
338            })()
339
340            if (needsPlaceholder)
341            {
342               # replace the backtick expression with an identifier
343               key <- .Call("rs_generateShortUuid")
344               exprs[[key]] <<- val
345               key
346            }
347            else
348            {
349               # leave other character expressions as-is
350               val
351            }
352         }
353         else
354         {
355            # leave non-character values alone
356            val
357         }
358      })
359   }
360
361   # substitute ticks and convert to yaml
362   yaml <- yaml::as.yaml(tick_sub(input))
363
364   # the yaml package produces UTF-8 output strings, but doesn't mark them
365   # as such, which leads to trouble (in particular: on Windows the string
366   # may be later interpreted in system default encoding, which is not UTF-8.)
367   # see: https://github.com/viking/r-yaml/issues/6
368   if (Encoding(yaml) == "unknown")
369      Encoding(yaml) <- "UTF-8"
370
371   # put the backticked expressions back
372   for (key in names(exprs))
373      yaml <- sub(key, exprs[[key]], yaml, fixed = TRUE)
374
375   list(yaml = .rs.scalar(yaml))
376})
377
378.rs.addJsonRpcHandler("convert_from_yaml", function(yaml)
379{
380   Encoding(yaml) <- "UTF-8"
381
382   data <- list()
383   parseError <- ""
384   parseSucceeded <- FALSE
385
386   tryCatch(
387   {
388      handlers <- list(r = function(x) paste("!r", x))
389      data <- .rs.scalarListFromList(yaml::yaml.load(yaml, handlers = handlers))
390      parseSucceeded <- TRUE
391   },
392   error = function(e)
393   {
394      parseError <<- as.character(e)
395   })
396   list(data = data,
397        parse_succeeded = .rs.scalar(parseSucceeded),
398        parse_error = .rs.scalar(parseError))
399})
400
401
402.rs.addJsonRpcHandler("rmd_output_format", function(input, encoding) {
403  if (Encoding(input) == "unknown")
404    Encoding(input) <- "UTF-8"
405  formats <- rmarkdown:::enumerate_output_formats(input, encoding = encoding)
406  if (is.character(formats))
407    .rs.scalar(formats[[1]])
408  else
409    NULL
410})
411
412.rs.addGlobalFunction("knit_with_parameters",
413                      function(file, encoding = getOption("encoding")) {
414
415   # result to return via event
416   result <- NULL
417
418   # check for parameters
419   if (length(knitr::knit_params(readLines(file,
420                                           warn = FALSE,
421                                           encoding = encoding),
422                                 evaluate = FALSE)) > 0) {
423
424      # allocate temp file to hold parameter values
425      paramsFile <- .Call("rs_paramsFileForRmd", file)
426
427      # read any existing parameters contained therin
428      params <- list()
429      if (file.exists(paramsFile))
430         params <- readRDS(paramsFile)
431
432      # ask for parameters
433      params <- rmarkdown::knit_params_ask(
434         file,
435         params = params,
436         shiny_args = list(
437            launch.browser = function(url, ...) {
438               .Call("rs_showShinyGadgetDialog",
439                     "Knit with Parameters",
440                     url,
441                     600,
442                     600)
443            },
444            quiet = TRUE),
445         save_caption = "Knit",
446         encoding = encoding
447      )
448
449      if (!is.null(params)) {
450         saveRDS(params, file = paramsFile)
451         result <- paramsFile
452      }
453
454   } else {
455      # return special "none" value if there are no params
456      result <- "none"
457   }
458
459   .rs.enqueClientEvent("rmd_params_ready", result)
460
461   invisible(NULL)
462})
463
464.rs.addJsonRpcHandler("get_rmd_output_info", function(target) {
465  return(.rs.getRmdOutputInfo(target))
466})
467
468.rs.addFunction("inputDirToIndexFile", function(input_dir)
469{
470   paths <- c(
471      file.path(input_dir, "index.Rmd"),
472      file.path(input_dir, "index.md")
473   )
474
475   for (path in paths)
476      if (file.exists(path))
477         return(path)
478})
479
480.rs.addFunction("getAllOutputFormats", function(input_dir, encoding) {
481   index <- .rs.inputDirToIndexFile(input_dir)
482   if (!is.null(index))
483      rmarkdown:::enumerate_output_formats(input = index,
484                                           envir = parent.frame(),
485                                           encoding = encoding)
486   else
487      character()
488})
489
490.rs.addFunction("isBookdownDir", function(input_dir, encoding) {
491   index <- .rs.inputDirToIndexFile(input_dir)
492   if (!is.null(index)) {
493
494      formats <- rmarkdown:::enumerate_output_formats(input = index,
495                                                      envir = parent.frame(),
496                                                      encoding = encoding)
497      any(grepl("^bookdown", formats))
498   }
499   else
500      FALSE
501})
502
503.rs.addFunction("bookdown.SourceFiles", function(input_dir) {
504   wd <- getwd()
505   on.exit(setwd(wd), add = TRUE)
506   setwd(input_dir)
507   bookdown:::source_files()
508})
509
510
511.rs.addFunction("bookdown.frontMatterValue", function(input_dir, value) {
512   wd <- getwd()
513   on.exit(setwd(wd), add = TRUE)
514   setwd(input_dir)
515   files <- bookdown:::source_files()
516   if (length(files) > 0)
517   {
518      index <- files[[1]]
519      front_matter <- rmarkdown::yaml_front_matter(index)
520      if (is.character(front_matter[[value]]))
521         front_matter[[value]]
522      else if (is.logical(front_matter[[value]]))
523         paste0("LOGICAL:",front_matter[[value]])
524      else
525         character()
526   }
527   else
528   {
529      character()
530   }
531})
532
533.rs.addFunction("isSiteProject", function(input_dir, encoding, site) {
534
535   index <- .rs.inputDirToIndexFile(input_dir)
536   if (!is.null(index)) {
537      any(grepl(site, readLines(index, encoding = encoding)))
538   }
539   else
540      FALSE
541})
542
543.rs.addFunction("tinytexRoot", function()
544{
545   # check for tlmgr path set via option; the tinytex root directory is
546   # always 2 directories up from that
547   tlmgr <- getOption("tinytex.tlmgr.path", default = NULL)
548   if (!is.null(tlmgr))
549   {
550      root <- dirname(dirname(dirname(tlmgr)))
551      return(root)
552   }
553
554   # otherwise, use default locations for different platforms
555   sysname <- Sys.info()[["sysname"]]
556   if (sysname == "Windows")
557      file.path(Sys.getenv("APPDATA"), "TinyTeX")
558   else if (sysname == "Darwin")
559      "~/Library/TinyTeX"
560   else
561      "~/.TinyTeX"
562})
563
564.rs.addFunction("tinytexBin", function()
565{
566   root <- .rs.tinytexRoot()
567   if (!file.exists(root))
568      return(NULL)
569
570   # NOTE: binary directory has a single arch-specific subdir;
571   # rather than trying to hard-code the architecture we just
572   # infer it directly.
573   #
574   # some users will end up with tinytex installations that
575   # 'exist', but are broken for some reason (no longer have
576   # a 'bin' directory). detect those cases properly
577   #
578   # https://github.com/rstudio/rstudio/issues/7615
579   bin <- file.path(root, "bin")
580   if (!file.exists(bin))
581      return(NULL)
582
583   subbin <- list.files(bin, full.names = TRUE)
584   if (length(subbin) == 0)
585      return(NULL)
586
587   normalizePath(subbin[[1]], mustWork = TRUE)
588})
589
590.rs.addFunction("bookdown.renderedOutputPath", function(websiteDir, outputPath)
591{
592   # if we have a PDF for this file, use it
593   if (tools::file_ext(outputPath) == "pdf")
594      return(outputPath)
595
596   # if that fails, use root index file
597   # note that this gets remapped as appropriate to knitted posts; see:
598   # https://github.com/rstudio/rstudio/issues/6945
599   index <- file.path(websiteDir, "index.html")
600   if (file.exists(index))
601      return(index)
602
603   # default to using output file path
604   # (necessary for self-contained books, which may not have an index)
605   outputPath
606})
607