1
2# Write an index.htm file for an Rmd deployment if necessary (returns the
3# files written so they can be removed after deployment)
4writeRmdIndex <- function(appName, appDir) {
5
6  # files written
7  files <- NULL
8
9  # no index required for Shiny, or for directories with an index.Rmd
10  if (!file.exists(file.path(appDir, "ui.R")) &&
11        !file.exists(file.path(appDir, "server.R")) &&
12        !file.exists(file.path(appDir, "index.htm")) &&
13        !file.exists(file.path(appDir, "index.Rmd")))
14  {
15    # otherwise enumerate the Rmd files as the basis for the index
16    appFiles <- list.files(path = appDir, pattern = "\\.(rmd|html)$",
17                           recursive = FALSE, ignore.case = TRUE)
18
19    if (length(appFiles) == 1)
20      indexPage <- redirectWebPage(appFiles[1])
21    else
22      indexPage <- listingWebPage(appName, appFiles)
23
24    indexFile <- file.path(appDir, "index.htm")
25    files <- c(files, indexFile)
26    writeLines(indexPage, indexFile, useBytes = TRUE)
27  }
28
29  files
30}
31
32redirectWebPage <- function(appFile) {
33  meta <- paste('<meta http-equiv="refresh" content="0;',
34                htmlEscape(appFile), '">', sep = "")
35  webPage(meta, NULL)
36}
37
38listingWebPage <- function(appDir, appFiles) {
39
40  head <- c("<style type='text/css'>",
41            "body { padding-left: 20px; }",
42            ".rmd { margin-bottom: 20px; }",
43            ".rmdlink { font-size: 1.5em; text-decoration: none; }",
44            ".rmdlink:hover { text-decoration: underline; }",
45            "</style>")
46
47  appDir <- htmlEscape(appDir)
48  appFiles <- htmlEscape(appFiles)
49
50  body <- paste("<h1>", basename(appDir), "</h1>", sep = "")
51  body <- c(body, paste("<div class = 'rmd'>",
52                        "<a href='", appFiles, "' class = 'rmdlink'>",
53                        appFiles,
54                        "</a></div>", sep = ""))
55
56  webPage(head, body)
57}
58
59webPage <- function(head, body) {
60
61  if (is.null(head))
62    head <- c()
63
64  if (is.null(body))
65    body <- c()
66
67  enc2utf8(c(
68    '<!DOCTYPE HTML>',
69    '<html>',
70    '<head>',
71    '<meta charset="UTF-8">',
72    head,
73    '</head>',
74    '<body>',
75    body,
76    '</body>',
77    '</html>')
78  )
79}
80
81htmlEscape <- local({
82
83  .htmlSpecials <- list(
84    `&` = '&amp;',
85    `<` = '&lt;',
86    `>` = '&gt;'
87  )
88  .htmlSpecialsPattern <- paste(names(.htmlSpecials), collapse='|')
89  .htmlSpecialsAttrib <- c(
90    .htmlSpecials,
91    `'` = '&#39;',
92    `"` = '&quot;',
93    `\r` = '&#13;',
94    `\n` = '&#10;'
95  )
96  .htmlSpecialsPatternAttrib <- paste(names(.htmlSpecialsAttrib), collapse='|')
97
98  function(text, attribute=FALSE) {
99    pattern <- if(attribute)
100      .htmlSpecialsPatternAttrib
101    else
102      .htmlSpecialsPattern
103
104    # Short circuit in the common case that there's nothing to escape
105    if (!any(grepl(pattern, text)))
106      return(text)
107
108    specials <- if(attribute)
109      .htmlSpecialsAttrib
110    else
111      .htmlSpecials
112
113    for (chr in names(specials)) {
114      text <- gsub(chr, specials[[chr]], text, fixed=TRUE)
115    }
116
117    return(text)
118  }
119})
120
121