1#' Helpers for importing web fonts
2#'
3#' @description
4#'
5#' Include font file(s) when defining a Sass variable that represents a CSS
6#' `font-family` property.
7#'
8#' @details
9#'
10#' These helpers **must be used the named list approach to variable
11#' definitions**, for example:
12#'
13#'  ```
14#'  list(
15#'    list("font-variable" = font_google("Pacifico")),
16#'    list("body{font-family: $font-variable}")
17#'  )
18#'  ```
19#'
20#' @section Font fallbacks:
21#'
22#'  By default, `font_google()` downloads, caches, and serves the relevant font
23#'  file(s) locally. By locally serving files, there's a guarantee that the font
24#'  can render in any client browser, even when the client doesn't have internet
25#'  access. However, when importing font files remotely (i.e., `font_google(...,
26#'  local = FALSE)` or `font_link()`), it's a good idea to provide fallback
27#'  font(s) in case the remote link isn't working (e.g., maybe the end user
28#'  doesn't have an internet connection). To provide fallback fonts, use
29#'  [font_collection()], for example:
30#'
31#'  ```
32#'  pacifico <- font_google("Pacifico", local = FALSE)
33#'  as_sass(list(
34#'    list("font-variable" = font_collection(pacifico, "system-ui")),
35#'    list("body{font-family: $font-variable}")
36#'  ))
37#'  ```
38#'
39#' @section Default flags:
40#'
41#'  These font helpers encourage best practice of adding a `!default` to Sass
42#'  variable definitions, but the flag may be removed via `font_collection()` if
43#'  desired.
44#'
45#'  ```
46#'  as_sass(list("font-variable" = pacifico))
47#'  #> $font-variable: Pacifico !default;
48#'  as_sass(list("font-variable" = font_collection(pacifico, default_flag = F)))
49#'  #> $font-variable: Pacifico;
50#'  ```
51#'
52#' @section Serving non-Google fonts locally:
53#'
54#'  Non-Google fonts may also be served locally with `font_face()`, but it
55#'  requires downloading font file(s) and pointing `src` to the right location
56#'  on disk. If you want `src` to be a relative file path (you almost certainly
57#'  do), then you'll need to mount that resource path using something like
58#'  [shiny::addResourcePath()] (for a shiny app) or `servr::httd()` (for static
59#'  HTML).
60#'
61#' @param family A character string with a _single_ font family name.
62#' @param local Whether or not download and bundle local (woff) font files.
63#' @param cache A [sass::sass_file_cache()] object (or, more generally, a file
64#'   caching class with `$get_file()` and `$set_file()` methods). Set this
65#'   argument to `FALSE` or `NULL` to disable caching.
66#' @param wght One of the following:
67#'   * `NULL`, the default weight for the `family`.
68#'   * A character string defining an [axis range](https://developers.google.com/fonts/docs/css2#axis_ranges)
69#'   * A numeric vector of desired font weight(s).
70#' @param ital One of the following:
71#'   * `NULL`, the default `font-style` for the `family`.
72#'   * `0`, meaning `font-style: normal`
73#'   * `1`, meaning `font-style: italic`
74#'   * `c(0, 1)`, meaning both `normal` and `italic`
75#' @param display the `font-display` `@font-face` property.
76#'
77#' @return a [sass_layer()] holding an [htmltools::htmlDependency()] which points
78#'   to the font files.
79#'
80#' @references <https://developers.google.com/fonts/docs/css2>
81#' @references <https://developer.mozilla.org/en-US/docs/Web/CSS/@font-face>
82#' @references <https://developer.mozilla.org/en-US/docs/Learn/CSS/Styling_text/Web_fonts>
83#'
84#' @export
85#' @rdname font_face
86#' @examples
87#'
88#' library(htmltools)
89#'
90#' my_font <- list("my-font" = font_google("Pacifico"))
91#' hello <- tags$body(
92#'   "Hello",
93#'   tags$style(
94#'     sass(
95#'       list(
96#'         my_font,
97#'         list("body {font-family: $my-font}")
98#'       )
99#'     )
100#'   )
101#' )
102#'
103#' if (interactive()) {
104#'   browsable(hello)
105#' }
106#'
107#' # Three different yet equivalent ways of importing a remotely-hosted Google Font
108#' a <- font_google("Crimson Pro", wght = "200..900", local = FALSE)
109#' b <- font_link(
110#'   "Crimson Pro",
111#'   href = "https://fonts.googleapis.com/css2?family=Crimson+Pro:wght@200..900"
112#' )
113#' url <- "https://fonts.gstatic.com/s/crimsonpro/v13/q5uDsoa5M_tv7IihmnkabARboYF6CsKj.woff2"
114#' c <- font_face(
115#'   family = "Crimson Pro",
116#'   style = "normal",
117#'   weight = "200 900",
118#'   src = paste0("url(", url, ") format('woff2')")
119#' )
120font_google <- function(family, local = TRUE,
121                        cache = sass_file_cache(sass_cache_context_dir()),
122                        wght = NULL, ital = NULL, display = c("swap", "auto", "block", "fallback", "optional")) {
123  stopifnot(is.logical(local))
124  if (!is.null(wght)) {
125    stopifnot(is.character(wght) || is.numeric(wght))
126    wght <- sort(wght)
127  }
128  if (!is.null(ital)) {
129    stopifnot(all(ital %in% c(0, 1)))
130    ital <- sort(ital)
131  }
132  display <- match.arg(display)
133
134  axis_rng <-
135    if (is.null(wght) && is.null(ital)) {
136      ""
137    } else if (is.null(ital)) {
138      paste0(":wght@", paste0(wght, collapse = ";"))
139    } else if (is.null(wght)) {
140      paste0(":ital@", paste0(ital, collapse = ";"))
141    } else {
142      paste0(":ital,wght@", paste0(
143        apply(expand.grid(wght, ital)[, 2:1], 1, paste0, collapse = ","),
144        collapse = ";"
145      ))
146    }
147
148  x <- list(
149    family = family,
150    local = isTRUE(local), cache = cache,
151    href = paste0(
152      "https://fonts.googleapis.com/css2?family=",
153      family, axis_rng, "&display=", display
154    )
155  )
156
157  dep_func <- if (x$local) font_dep_google_local else font_dep_link
158  font_object(x, dep_func)
159}
160
161#' @rdname font_face
162#' @export
163#' @param href A URL resource pointing to the font data.
164font_link <- function(family, href) {
165  font_object(list(family = family, href = href), font_dep_link)
166}
167
168#' @rdname font_face
169#' @export
170#' @param src A character vector for the `src` `@font-face` property. Beware
171#'   that is character strings are taken verbatim, so careful quoting and/or URL
172#'   encoding may be required.
173#' @param weight A character (or numeric) vector for the `font-weight`
174#'   `@font-face` property.
175#' @param display A character vector for the `font-display` `@font-face`
176#'   property.
177#' @param style A character vector for the `font-style` `@font-face` property.
178#' @param stretch A character vector for the `font-stretch` `@font-face`
179#'   property.
180#' @param variant A character vector for the `font-variant` `@font-face`
181#'   property.
182#' @param unicode_range A character vector for `unicode-range` `@font-face`
183#'   property.
184font_face <- function(family, src, weight = NULL, style = NULL,
185                      display = c("swap", "auto", "block", "fallback", "optional"),
186                      stretch = NULL, variant = NULL, unicode_range = NULL) {
187
188  x <- dropNulls(list(
189    family = quote_css_font_families(family),
190    src = src,
191    weight = weight,
192    style = style,
193    display = if (!is.null(display)) match.arg(display),
194    stretch = stretch,
195    variant = variant,
196    unicode_range = unicode_range
197  ))
198
199  # Multiple src values are separated by "," (everything else by white space)
200  # TODO: src could accept a list of named lists which might give us the
201  # opportunity to handle quoting and encoding of URLs
202  for (prop in names(x)) {
203    collapse <- switch(prop, src = , unicode_range = ", ", " ")
204    x[[prop]] <- paste0(x[[prop]], collapse = collapse)
205  }
206  x$css <- font_face_css(x)
207
208  font_object(x, font_dep_face)
209}
210
211font_face_css <- function(x) {
212  props <- names(x)
213  font_prop <- !props %in% c("src", "unicode_range")
214  props[font_prop] <- paste0("font-", props[font_prop])
215  paste0(
216    "@font-face {\n",
217    paste0("  ", props, ": ", x, ";", collapse = "\n"),
218    "\n}"
219  )
220}
221
222font_object <- function(x, dep_func) {
223  stopifnot(is.function(dep_func))
224  if (!is_string(x$family)) {
225    stop(
226      "Font `family` definitions must be a character string (length 1).",
227      call. = FALSE
228    )
229  }
230  # Dependency functions want to use unquoted family name
231  new_font_collection(
232    families = x$family,
233    # Produce dependency at render-time (i.e., tagFunction())
234    # so the context-aware caching dir has the proper context
235    html_deps = tagFunction(function() dep_func(x))
236  )
237}
238
239#' @rdname font_face
240#' @param ... a collection of `font_google()`, `font_link()`, `font_face()`, and/or character vector(s) (i.e., family names to include in the CSS `font-family` properly). Family names are automatically quoted as necessary.
241#' @param default_flag whether or not to include a `!default` when converted to a Sass variable with [as_sass()].
242#' @param quote whether or not to attempt automatic quoting of family names.
243#' @export
244font_collection <- function(..., default_flag = TRUE, quote = TRUE) {
245  fonts <- dropNulls(list2(...))
246
247  # Transform syntax like font_collection(google = "Pacifico")
248  # into font_collection(font_google("Pacifico"))
249  # the primary motication for doing this is to support a Rmd
250  # syntax like this (for bslib theming):
251  # ---
252  # theme:
253  #   base_font:
254  #     google: Pacifico
255  # ---
256  fonts <- Map(
257    names2(fonts), fonts,
258    f = function(nm, val) {
259      if (identical(nm, "")) return(val)
260
261      func <- known_font_helpers[[nm]] %||% rlang::abort(
262        paste0(
263          "Unsupported argument name: ", nm, ".\n",
264          "Did you want to try one of these names instead: ",
265          paste0(names(known_font_helpers), collapse = ", "), "?"
266        )
267      )
268
269      do.call(func, as.list(val))
270    }
271  )
272
273  families <- lapply(fonts, function(x) {
274    if (is_font_collection(x))
275      return(x$families)
276    if (is.character(x) && isTRUE(all(nzchar(x, keepNA = TRUE))))
277      return(x)
278    stop(
279      "`font_collection()` expects a collection of `font_google()`, `font_link()`, `font_face()`, and/or non-empty character strings.",
280      call. = FALSE
281    )
282  })
283
284  families <- unlist(families, recursive = FALSE, use.names = FALSE)
285
286  deps <- lapply(fonts, function(x) {
287    if (is_font_collection(x)) x$html_deps
288  })
289  new_font_collection(
290    families = families,
291    html_deps = unlist(deps, recursive = FALSE, use.names = FALSE),
292    default_flag = isTRUE(default_flag),
293    quote = quote
294  )
295}
296
297
298known_font_helpers <- list(
299  "google" = font_google,
300  "link" = font_link,
301  "face" = font_face,
302  "collection" = font_collection
303)
304
305new_font_collection <- function(families, html_deps, default_flag = TRUE, quote = TRUE) {
306  add_class(
307    list(
308      families = if (isTRUE(quote)) quote_css_font_families(families) else families,
309      html_deps = html_deps,
310      default_flag = default_flag
311    ),
312    "font_collection"
313  )
314}
315
316#' @rdname font_face
317#' @param x test whether `x` is a `font_collection()`, `font_google()`, `font_link()`, or `font_face()` object.
318#' @export
319is_font_collection <- function(x) {
320  inherits(x, "font_collection")
321}
322
323quote_css_font_families <- function(x) {
324  stopifnot(is.character(x))
325
326  quoted_contents <- c(
327    unlist(regmatches(x, gregexpr("'([^']*)'", x))),
328    unlist(regmatches(x, gregexpr('"([^"]*)"', x)))
329  )
330  if (any(grepl(",", quoted_contents))) {
331    x <- paste0(x, collapse = ", ")
332    warning(
333      "`sass::font_collection()` doesn't automatically quote CSS ",
334      "`font-family` names when they contain a ','. ",
335      "If fonts don't render properly, make sure family names are ",
336      "quoted properly: ", x,
337      call. = FALSE
338    )
339    return(x)
340  }
341
342  pieces <- trim_ws(unlist(strsplit(x, ",")))
343
344  # Are there non-alpha, non-dash characters? If so, then quote
345  needs_quote <- grepl("[^A-Za-z-]", pieces, perl = TRUE)
346  has_quote <- grepl("^'", pieces) | grepl('^"', pieces)
347  pieces <- ifelse(
348    needs_quote & !has_quote,
349    paste0("'", pieces, "'"),
350    pieces
351  )
352
353  paste0(pieces, collapse = ", ")
354}
355
356
357font_dep_name <- function(x) {
358  sub("\\s*", "_", trim_ws(x$family))
359}
360
361#' @import htmltools
362font_dep_face <- function(x) {
363  # TODO: memoise::memoise() this or do something similar
364  # to output_template() to reduce file redundancy?
365  src_dir <- tempfile()
366  dir.create(src_dir)
367  writeLines(x$css, file.path(src_dir, "font.css"))
368  htmlDependency(
369    font_dep_name(x), packageVersion("sass"),
370    src = src_dir,
371    stylesheet = "font.css",
372    all_files = FALSE
373  )
374}
375
376font_dep_link <- function(x) {
377  htmlDependency(
378    font_dep_name(x), packageVersion("sass"),
379    head = format(tags$link(
380      href = utils::URLencode(x$href),
381      rel = "stylesheet"
382    )),
383    # The src dir doesn't actually matter...this is just a way
384    # to pass along <link> tags as a dependency
385    src = tempdir(), all_files = FALSE
386  )
387}
388
389# -------------------------------------------------------
390# Local dependency logic
391# -------------------------------------------------------
392
393# For our purposes, cache objects must support these methods.
394is_cache_object <- function(x) {
395  # Use tryCatch in case the object does not support `$`.
396  tryCatch(
397    is.function(x$get_file) && is.function(x$set_file),
398    error = function(e) FALSE
399  )
400}
401
402resolve_cache <- function(cache) {
403  if (is_cache_object(cache)) return(cache)
404  list(
405    get_file = function(...) FALSE,
406    set_file = function(...) FALSE
407  )
408}
409
410font_dep_google_local <- function(x) {
411  # TODO: memoise::memoise() this or do something similar
412  # to output_template() to reduce file redundancy?
413  tmpdir <- tempfile()
414  dir.create(tmpdir, recursive = TRUE)
415  css_file <- file.path(tmpdir, "font.css")
416
417  # TODO: could the hash be more aware of when the href updates?
418  x$cache <- resolve_cache(x$cache)
419  css_key <- rlang::hash(x$href)
420  css_hit <- x$cache$get_file(css_key, css_file)
421
422  # Even if we have a cache hit on the CSS file, we may need
423  # to re-download font file(s) if they've been pruned from the cache
424  css <- if (css_hit) readLines(css_file) else read_gfont_url(x$href, css_file)
425
426  # basename() of these url()s contain a hash key of the font data
427  urls <- extract_group(css, "url\\(([^)]+)")
428  basenames <- basename(urls)
429
430  # If need be, download the font file(s) that the CSS imports,
431  # and modify the CSS to point to the local files
432  Map(function(url, nm) {
433    key <- rlang::hash(nm)
434    f <- file.path(tmpdir, nm)
435    hit <- x$cache$get_file(key, f)
436    if (hit) return()
437    # In the event we have a CSS cache hit but miss here, url should actually be
438    # a local file. In that case, bust the CSS cache, and start over so we know
439    # where to find the font files
440    if (!grepl("^\\s*http", url)) {
441      x$cache$remove(css_key)
442      return(font_dep_google_local(x))
443    }
444    download_file(url, f)
445    x$cache$set_file(key, f)
446    css <<- sub(url, nm, css, fixed = TRUE)
447  }, urls, basenames)
448
449  # Cache the *modified* form of the CSS file
450  # (with the local file paths instead of remote URLs)
451  if (!css_hit) {
452    writeLines(css, css_file)
453    x$cache$set_file(css_key, css_file)
454  }
455
456  htmltools::htmlDependency(
457    font_dep_name(x), packageVersion("sass"),
458    src = dirname(css_file),
459    stylesheet = basename(css_file),
460    all_files = TRUE
461  )
462}
463
464# Request the relevant @font-face definitions for the font url
465# (without the IE11 user-agent header we'd get truetype fonts, but
466# there's no reason why we can't use woff, which IE11 supports)
467read_gfont_url <- function(url, file) {
468  download_file(
469    utils::URLencode(url), file,
470    headers = c(
471      "User-Agent" = "Mozilla/5.0 (Windows NT 10.0; WOW64; Trident/7.0; rv:11.0) like Gecko"
472    )
473  )
474  readLines(file)
475}
476
477extract_group <- function(x, pattern, which = 1) {
478  matches <- regmatches(x, regexec(pattern, x))
479  na.omit(sapply(matches, "[", which + 1))
480}
481
482# similar to thematic:::download_file, but also translates headers to curl
483#' @importFrom stats na.omit
484#' @importFrom utils download.file packageVersion
485download_file <- function(url, dest, headers = NULL, ...) {
486  if (is_available("curl")) {
487    if (!curl::has_internet()) {
488      warning(
489        "Looks like you don't have internet access, which is needed to ",
490        "download and install Google Fonts files. Try either changing ",
491        "thematic::font_spec(), manually installing the relevant font, or ",
492        "trying again with internet access.",
493        call. = FALSE
494      )
495    }
496    handle <- curl::handle_setheaders(curl::new_handle(), .list = headers)
497    return(curl::curl_download(url, dest, handle = handle, quiet = FALSE, ...))
498  }
499
500  if (capabilities("libcurl")) {
501    return(download.file(url, dest, method = "libcurl", headers = headers, ...))
502  }
503
504  stop(
505    "Downloading Google Font files requires either the curl package or ",
506    "`capabilities('libcurl')`. ", call. = FALSE
507  )
508}
509