| # File src/library/tools/R/dynamicHelp.R |
| # Part of the R package, https://www.R-project.org |
| # |
| # Copyright (C) 1995-2018 The R Core Team |
| # |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 2 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # A copy of the GNU General Public License is available at |
| # https://www.R-project.org/Licenses/ |
| |
| |
| ## This may be asked for |
| ## R.css, favicon.ico |
| ## searches with path = "/doc/html/Search" |
| ## documentation with path = "/doc/....", possibly updated under tempdir()/.R |
| ## demos with path "/demo/*" |
| ## Running demos, using path "/Demo/*" |
| ## html help, either by topic, /library/<pkg>/help/<topic> (pkg=NULL means any) |
| ## or by file, /library/<pkg>/html/<file>.html |
| httpd <- function(path, query, ...) |
| { |
| .HTMLdirListing <- function(dir, base, up) { |
| files <- list.files(dir) # note, no hidden files are listed |
| out <- HTMLheader(paste0("Listing of directory<br/>", dir), |
| headerTitle = paste("R:", dir), logo=FALSE, |
| up = up) |
| if(!length(files)) |
| out <- c(out, gettext("No files in this directory")) |
| else { |
| urls <- paste0('<a href="', base, '/', files, '">', files, '</a>') |
| out <- c(out, "<dl>", |
| paste0("<dd>", mono(iconv(urls, "", "UTF-8")), "</dd>"), |
| "</dl>") |
| } |
| out <- c(out, "<hr/>\n</body></html>") |
| list(payload = paste(out, collapse="\n")) |
| } |
| |
| .HTMLusermanuals <- function() { |
| pkgs <- unlist(.get_standard_package_names()) |
| |
| out <- HTMLheader("R User Manuals") |
| for (pkg in pkgs) { |
| vinfo <- getVignetteInfo(pkg) |
| if (nrow(vinfo)) |
| out <- c(out, paste0('<h2>Manuals in package', sQuote(pkg),'</h2>'), |
| makeVignetteTable(cbind(Package=pkg, vinfo[,c("File", "Title", "PDF", "R"), drop = FALSE]))) |
| } |
| out <- c(out, "<hr/>\n</body></html>") |
| list(payload = paste(out, collapse="\n")) |
| } |
| |
| .HTMLsearch <- function(query) { |
| bool <- function(x) as.logical(as.numeric(x)) |
| res <- if(identical(names(query), "category")) { |
| utils::help.search(keyword = query, verbose = 1L, use_UTF8 = TRUE) |
| } else if(identical(names(query), c("objects", "port"))) { |
| .httpd_objects(query["port"]) |
| } else { |
| fields <- types <- NULL |
| args <- list(pattern = ".") |
| for (i in seq_along(query)) |
| switch(names(query)[i], |
| pattern = args$pattern <- query[i], |
| fields.alias = |
| if(bool(query[i])) |
| fields <- c(fields, "alias"), |
| fields.title = |
| if(bool(query[i])) |
| fields <- c(fields, "title"), |
| fields.concept = |
| if(bool(query[i])) |
| fields <- c(fields, "concept"), |
| fields.keyword = |
| if(bool(query[i])) |
| fields <- c(fields, "keyword"), |
| ignore.case = |
| args$ignore.case <- bool(query[i]), |
| agrep = |
| args$agrep <- bool(query[i]), |
| types.help = |
| if(bool(query[i])) |
| types <- c(types, "help"), |
| types.vignette = |
| if(bool(query[i])) |
| types <- c(types, "vignette"), |
| types.demo = |
| if(bool(query[i])) |
| types <- c(types, "demo"), |
| ## Possibly passed from utils:::printhsearchInternal(). |
| package = args$package <- strsplit(query[i], ";")[[1L]], |
| lib.loc = args$lib.loc <- strsplit(query[i], ";")[[1L]], |
| warning("Unrecognized search field: ", names(query)[i], |
| domain = NA) |
| ) |
| args$fields <- fields |
| args$use_UTF8 <- TRUE |
| args$types <- types |
| do.call(utils::help.search, args) |
| } |
| types <- res$types |
| res <- res$matches |
| title <- "Search Results" |
| out <- c(HTMLheader(title), |
| if ("pattern" %in% names(query) && nchar(query["pattern"])) |
| paste0('The search string was <b>"', query["pattern"], '"</b>'), |
| '<hr/>\n') |
| |
| if(!NROW(res)) |
| out <- c(out, gettext("No results found")) |
| else { |
| vigfile0 <- "" |
| vigDB <- NULL |
| for (type in types) { |
| if(NROW(temp <- res[res[,"Type"] == type, , drop=FALSE]) > 0) { |
| temp <- temp[!duplicated(temp[, "ID"]), , drop = FALSE] |
| switch(type, |
| vignette = { |
| out <- c(out, paste0("<h3>", gettext("Vignettes:"), "</h3>"), "<dl>") |
| n <- NROW(temp) |
| vignettes <- matrix("", n, 5L) |
| colnames(vignettes) <- |
| c("Package", "File", "Title", "PDF", "R") |
| for (i in seq_len(NROW(temp))) { |
| topic <- temp[i, "Topic"] |
| pkg <- temp[i, "Package"] |
| vigfile <- file.path(temp[i, "LibPath"], "Meta", "vignette.rds") |
| if (!identical(vigfile, vigfile0)) { |
| vigDB <- readRDS(vigfile) |
| vigfile0 <- vigfile |
| } |
| vignette <- vigDB[topic == file_path_sans_ext(vigDB$PDF),] |
| # There should be exactly one row in the result, but |
| # bad packages might have more, e.g. vig.Snw and vig.Rnw |
| vignettes[i,] <- c(pkg, unlist(vignette[1,c("File", "Title", "PDF", "R")])) |
| } |
| out <- c(out, makeVignetteTable(vignettes)) |
| }, |
| demo = { |
| out <- c(out, paste0("<h3>", gettext("Code demonstrations:"), "</h3>")) |
| out <- c(out, makeDemoTable(temp)) |
| }, |
| help = { |
| out <- c(out, paste0("<h3>", gettext("Help pages:"), "</h3>")) |
| out <- c(out, makeHelpTable(temp)) |
| }) |
| } |
| } |
| } |
| out <- c(out, "<hr/>\n</body></html>") |
| list(payload = paste(out, collapse="\n")) |
| } |
| |
| .HTML_hsearch_db_concepts <- function() { |
| concepts <- utils::hsearch_db_concepts() |
| s <- concepts$Concept |
| out <- |
| c(HTMLheader("Help search concepts"), |
| c("", |
| "<table>", |
| "<tr><th style=\"text-align: left\">Concept</th><th>Frequency</th><th>Packages</th><tr>", |
| paste0("<tr><td>", |
| "<a href=\"/doc/html/Search?pattern=", |
| vapply(reQuote(s), utils::URLencode, "", reserved = TRUE), |
| "&fields.concept=1&agrep=0\">", |
| shtmlify(substring(s, 1, 80)), |
| "</a>", |
| "</td><td style=\"text-align: right\">", |
| concepts$Frequency, |
| "</td><td style=\"text-align: right\">", |
| concepts$Packages, |
| "</td></tr>"), |
| "</table>", |
| "</body>", |
| "</html>")) |
| list(payload = paste(out, collapse = "\n")) |
| } |
| |
| .HTML_hsearch_db_keywords <- function() { |
| keywords <- utils::hsearch_db_keywords() |
| out <- |
| c(HTMLheader("Help search keywords"), |
| c("", |
| "<table>", |
| "<tr><th style=\"text-align: left\">Keyword</th><th style=\"text-align: left\">Concept</th><th>Frequency</th><th>Packages</th><tr>", |
| paste0("<tr><td>", |
| "<a href=\"/doc/html/Search?category=", |
| keywords$Keyword, |
| "\">", |
| keywords$Keyword, |
| "</a>", |
| "</td><td>", |
| shtmlify(substring(keywords$Concept, 1, 80)), |
| "</td><td style=\"text-align: right\">", |
| keywords$Frequency, |
| "</td><td style=\"text-align: right\">", |
| keywords$Packages, |
| "</td></tr>"), |
| "</table>", |
| "</body>", |
| "</html>")) |
| list(payload = paste(out, collapse = "\n")) |
| } |
| |
| unfix <- function(file) { |
| ## we need to re-fix links altered by fixup.package.URLs |
| ## in R < 2.10.0 |
| fixedfile <- sub("/html/.*", "/fixedHTMLlinks", file) |
| if(file.exists(fixedfile)) { |
| top <- readLines(fixedfile) |
| lines <- readLines(file) |
| lines <- gsub(paste0(top, "/library"), |
| "../../", lines, fixed = TRUE) |
| lines <- gsub(paste0(top, "/doc/"), |
| "../../../doc/", lines, fixed = TRUE) |
| return(list(payload=paste(lines, collapse="\n"))) |
| } |
| list(file = file) |
| } |
| |
| mime_type <- function(path) { |
| ext <- strsplit(path, ".", fixed = TRUE)[[1L]] |
| if(n <- length(ext)) ext <- ext[n] else "" |
| switch(ext, |
| "css" = "text/css", |
| "gif" = "image/gif", # in R2HTML |
| "jpg" = "image/jpeg", |
| "png" = "image/png", |
| "svg" = "image/svg+xml", |
| "html" = "text/html", |
| "pdf" = "application/pdf", |
| "eps" =, |
| "ps" = "application/postscript", # in GLMMGibbs, mclust |
| "sgml" = "text/sgml", # in RGtk2 |
| "xml" = "text/xml", # in RCurl |
| "text/plain") |
| } |
| |
| charsetSetting <- function(pkg) { |
| encoding <- read.dcf(system.file("DESCRIPTION", package=pkg), |
| "Encoding") |
| if (is.na(encoding)) |
| "" |
| else |
| paste0("; charset=", encoding) |
| } |
| |
| sQuote <- function(text) |
| paste0("‘", text, "’") |
| mono <- function(text) |
| paste0('<span class="samp">', text, "</span>") |
| |
| error_page <- function(msg) |
| list(payload = |
| paste0(HTMLheader("httpd error"), msg, "\n</body></html>")) |
| |
| cssRegexp <- "^/library/([^/]*)/html/R.css$" |
| if (grepl("R\\.css$", path) && !grepl(cssRegexp, path)) |
| return(list(file = file.path(R.home("doc"), "html", "R.css"), |
| "content-type" = "text/css")) |
| else if(path == "/favicon.ico") |
| return(list(file = file.path(R.home("doc"), "html", "favicon.ico"))) |
| else if(path == "/NEWS") |
| return(list(file = file.path(R.home("doc"), "html", "NEWS.html"), |
| "content-type" = "text/html")) |
| else if(grepl("^/NEWS[.][[:digit:]]$", path)) |
| return(list(file = file.path(R.home("doc"), sub("/", "", path)), |
| "content-type" = "text/plain; charset=utf-8")) |
| else if((path == "/doc/html/NEWS.html") && |
| identical(names(query), c("objects", "port"))) { |
| news <- .httpd_objects(query["port"]) |
| formatted <- toHTML(news, title = "R News") |
| return( list(payload = paste(formatted, collapse="\n")) ) |
| } |
| else if(!grepl("^/(doc|library|session)/", path)) |
| return(error_page(paste("Only NEWS and URLs under", mono("/doc"), |
| "and", mono("/library"), "are allowed"))) |
| else if(path == "/doc/html/UserManuals.html") |
| return(.HTMLusermanuals()) |
| else if(path == "/doc/html/hsearch_db_concepts.html") |
| return(.HTML_hsearch_db_concepts()) |
| else if(path == "/doc/html/hsearch_db_keywords.html") |
| return(.HTML_hsearch_db_keywords()) |
| |
| |
| ## ----------------------- per-package documentation --------------------- |
| ## seems we got ../..//<pkg> in the past |
| fileRegexp <- "^/library/+([^/]*)/html/([^/]*)\\.html$" |
| topicRegexp <- "^/library/+([^/]*)/help/([^/]*)$" |
| docRegexp <- "^/library/([^/]*)/doc(.*)" |
| demoRegexp <- "^/library/([^/]*)/demo$" |
| demosRegexp <- "^/library/([^/]*)/demo/([^/]*)$" |
| DemoRegexp <- "^/library/([^/]*)/Demo/([^/]*)$" |
| newsRegexp <- "^/library/([^/]*)/NEWS$" |
| figureRegexp <- "^/library/([^/]*)/(help|html)/figures/([^/]*)$" |
| sessionRegexp <- "^/session/" |
| |
| file <- NULL |
| if (grepl(topicRegexp, path)) { |
| ## ----------------------- package help by topic --------------------- |
| pkg <- sub(topicRegexp, "\\1", path) |
| if (pkg == "NULL") pkg <- NULL # There were multiple hits in the console |
| topic <- sub(topicRegexp, "\\2", path) |
| ## if a package is specified, look there first, then everywhere |
| if (!is.null(pkg)) # () avoids deparse here |
| file <- utils::help(topic, package = (pkg), help_type = "text") |
| if (!length(file)) |
| file <- utils::help(topic, help_type = "text", try.all.packages = TRUE) |
| if (!length(file)) { |
| msg <- gettextf("No help found for topic %s in any package.", |
| mono(topic)) |
| return(list(payload = error_page(msg))) |
| } else if (length(file) == 1L) { |
| path <- dirname(dirname(file)) |
| file <- paste0('../../', basename(path), '/html/', |
| basename(file), '.html') |
| ## cat("redirect to", file, "\n") |
| ## We need to do this because there are static HTML pages |
| ## with links to "<file>.html" for topics in the same |
| ## package, and if we served one of such a page as a link from |
| ## a different package those links on the page would not work. |
| return(list(payload = paste0('Redirect to <a href="', file, '">"', |
| basename(file), '"</a>'), |
| "content-type" = 'text/html', |
| header = paste0('Location: ', file), |
| "status code" = 302L)) # temporary redirect |
| } else if (length(file) > 1L) { |
| paths <- dirname(dirname(file)) |
| fp <- file.path(paths, "Meta", "Rd.rds") |
| tp <- basename(file) |
| titles <- tp |
| for (i in seq_along(fp)) { |
| tmp <- try(readRDS(fp[i])) |
| titles[i] <- if(inherits(tmp, "try-error")) |
| "unknown title" else |
| tmp[file_path_sans_ext(tmp$File) == tp[i], "Title"] |
| } |
| packages <- paste0('<dt><a href="../../', |
| basename(paths), '/html/', |
| basename(file), '.html">', titles, |
| '</a></dt><dd> (in package <a href="../../', |
| basename(paths), |
| '/html/00Index.html">', basename(paths), |
| '</a> in library ', dirname(paths), ")</dd>", |
| collapse = "\n") |
| |
| return(list(payload = |
| paste0("<p>", |
| ## for languages with multiple plurals .... |
| sprintf(ngettext(length(paths), |
| "Help on topic '%s' was found in the following package:", |
| "Help on topic '%s' was found in the following packages:" |
| ), topic), |
| "</p><dl>\n", |
| packages, "</dl>", |
| collapse = "\n") |
| )) |
| } |
| } else if (grepl(fileRegexp, path)) { |
| ## ----------------------- package help by file --------------------- |
| pkg <- sub(fileRegexp, "\\1", path) |
| helpdoc <- sub(fileRegexp, "\\2", path) |
| if (helpdoc == "00Index") { |
| ## ------------------- package listing --------------------- |
| file <- system.file("html", "00Index.html", package = pkg) |
| if(!nzchar(file) || !file.exists(file)) { |
| msg <- if(nzchar(system.file(package = pkg))) |
| gettextf("No package index found for package %s", |
| mono(pkg)) |
| else |
| gettextf("No package named %s could be found", |
| mono(pkg)) |
| return(error_page(msg)) |
| } else { |
| if(.Platform$OS.type == "windows") return(unfix(file)) |
| return(list(file = file)) |
| } |
| } |
| ## ----------------------- package help file --------------------- |
| path <- system.file("help", package = pkg) |
| if (!nzchar(path)) { |
| msg <- if(nzchar(system.file(package = pkg))) |
| gettextf("No help found for package %s", mono(pkg) ) |
| else |
| gettextf("No package named %s could be found", mono(pkg)) |
| return(error_page(msg)) |
| } |
| ## if 'topic' is not a help doc, try it as an alias in the package |
| contents <- readRDS(sub("/help", "/Meta/Rd.rds", path, fixed = TRUE)) |
| files <- sub("\\.[Rr]d$", "", contents$File) |
| if(helpdoc %notin% files) { |
| ## or call help() |
| aliases <- contents$Aliases |
| lens <- lengths(aliases) |
| aliases <- structure(rep.int(contents$File, lens), |
| names = unlist(aliases)) |
| tmp <- sub("\\.[Rr]d$", "", aliases[helpdoc]) |
| if(is.na(tmp)) { |
| msg <- gettextf("Link %s in package %s could not be located", |
| mono(helpdoc), mono(pkg)) |
| files <- utils::help(helpdoc, help_type = "text", |
| try.all.packages = TRUE) |
| if (length(files)) { |
| path <- dirname(dirname(files)) |
| files <- paste0('/library/', basename(path), '/html/', |
| basename(files), '.html') |
| msg <- c(msg, "<br/>", |
| "However, you might be looking for one of", |
| "<p></p>", |
| paste0('<p><a href="', files, '">', |
| mono(files), "</a></p>") |
| ) |
| } |
| return(error_page(paste(msg, collapse = "\n"))) |
| } |
| helpdoc <- tmp |
| } |
| |
| ## Now we know which document we want in which package |
| dirpath <- dirname(path) |
| ## pkgname <- basename(dirpath) |
| ## RdDB <- file.path(path, pkgname) |
| outfile <- tempfile("Rhttpd") |
| Rd2HTML(utils:::.getHelpFile(file.path(path, helpdoc)), |
| out = outfile, package = dirpath, |
| dynamic = TRUE) |
| on.exit(unlink(outfile)) |
| return(list(payload = paste(readLines(outfile), collapse = "\n"))) |
| } else if (grepl(docRegexp, path)) { |
| ## ----------------------- package doc directory --------------------- |
| pkg <- sub(docRegexp, "\\1", path) |
| rest <- sub(docRegexp, "\\2", path) |
| docdir <- system.file("doc", package = pkg) |
| up <- paste0("/library/", pkg, "/html/00Index.html") |
| if(!nzchar(docdir)) |
| return(error_page(gettextf("No docs found for package %s", |
| mono(pkg)))) |
| if(nzchar(rest) && rest != "/") { |
| file <- paste0(docdir, rest) |
| exists <- file.exists(file) |
| if (!exists && rest == "/index.html") { |
| rest <- "" |
| file <- docdir |
| } |
| if(dir.exists(file)) |
| return(.HTMLdirListing(file, |
| paste0("/library/", pkg, "/doc", rest), |
| up)) |
| else if (exists) |
| return(list(file = file, "content-type" = mime_type(rest))) |
| else |
| return(error_page(gettextf("URL %s was not found", mono(path)))) |
| } else { |
| ## request to list <pkg>/doc |
| return(.HTMLdirListing(docdir, |
| paste("/library", pkg, "doc", sep="/"), |
| up)) |
| } |
| } else if (grepl(demoRegexp, path)) { |
| pkg <- sub(demoRegexp, "\\1", path) |
| |
| url <- paste0("http://127.0.0.1:", httpdPort(), |
| "/doc/html/Search?package=", |
| pkg, "&agrep=0&types.demo=1&pattern=") |
| return(list(payload = paste0('Redirect to <a href="', url, |
| '">help.search()</a>'), |
| "content-type" = 'text/html', |
| header = paste0('Location: ', url), |
| "status code" = 302L)) # temporary redirect |
| } else if (grepl(demosRegexp, path)) { |
| pkg <- sub(demosRegexp, "\\1", path) |
| demo <- sub(demosRegexp, "\\2", path) |
| file <- system.file(file.path("demo", demo), package=pkg) |
| return(list(file = file, "content-type" = mime_type(demo))) |
| |
| } else if (grepl(DemoRegexp, path)) { |
| pkg <- sub(DemoRegexp, "\\1", path) |
| demo <- sub(DemoRegexp, "\\2", path) |
| demo(demo, package=pkg, character.only=TRUE, ask=FALSE) |
| return( list(payload = paste0("Demo '", pkg, "::", demo, |
| "' was run in the console.", |
| " To repeat, type 'demo(", |
| pkg, "::", demo, |
| ")' in the console.")) ) |
| } else if (grepl(newsRegexp, path)) { |
| pkg <- sub(newsRegexp, "\\1", path) |
| if(identical(names(query), c("objects", "port"))) |
| news <- .httpd_objects(query["port"]) |
| else { |
| ## <FIXME> |
| ## This should no longer be used ... |
| if (!is.null(query) && !is.na(subset <- query["subset"])) { |
| ## See utils:::print.news_db for the encoding of the |
| ## subset |
| rle <- strsplit(subset, "_")[[1L]] |
| rle <- structure(list(lengths = as.numeric(rle), |
| values = rep_len(c(TRUE, FALSE), |
| length(rle))), |
| class = "rle") |
| news <- news(inverse.rle(rle)[-1L], package = pkg) |
| } else |
| news <- news(package = pkg) |
| ## </FIXME> |
| } |
| formatted <- toHTML(news, |
| title=paste("NEWS in package", sQuote(pkg)), |
| up="html/00Index.html") |
| if (length(formatted)) |
| return( list(payload = paste(formatted, collapse="\n")) ) |
| else |
| return( list(file = system.file("NEWS", package = pkg), |
| "content-type" = paste0("text/plain", charsetSetting(pkg) ) ) ) |
| } else if (grepl(figureRegexp, path)) { |
| pkg <- sub(figureRegexp, "\\1", path) |
| fig <- sub(figureRegexp, "\\3", path) |
| file <- system.file("help", "figures", fig, package=pkg) |
| return( list(file=file, "content-type" = mime_type(fig)) ) |
| } else if (grepl(sessionRegexp, path)) { |
| tail <- sub(sessionRegexp, "", path) |
| file <- file.path(tempdir(), tail) |
| return( list(file=file, "content-type" = mime_type(tail)) ) |
| } else if (grepl(cssRegexp, path)) { |
| pkg <- sub(cssRegexp, "\\1", path) |
| return( list(file = system.file("html", "R.css", package = pkg), |
| "content-type" = "text/css") ) |
| } else if (startsWith(path, "/library/")) { |
| descRegexp <- "^/library/+([^/]+)/+DESCRIPTION$" |
| if(grepl(descRegexp, path)) { |
| pkg <- sub(descRegexp, "\\1", path) |
| file <- system.file("DESCRIPTION", package = pkg) |
| return(list(file = file, "content-type" = paste0("text/plain", charsetSetting(pkg)))) |
| } else |
| return(error_page(gettextf("Only help files, %s, %s and files under %s and %s in a package can be viewed", mono("NEWS"), |
| mono("DESCRIPTION"), mono("doc/"), mono("demo/")))) |
| } |
| |
| ## ----------------------- R docs --------------------- |
| if(path == "/doc/html/Search.html") { |
| ## redirect to the page that has search enabled |
| list(file = file.path(R.home("doc"), "html/SearchOn.html")) |
| } else if(path == "/doc/html/Search") { |
| .HTMLsearch(query) |
| } else if(path == "/doc/html/packages.html") { |
| ## remake as needed |
| utils::make.packages.html(temp = TRUE) |
| list(file = file.path(tempdir(), ".R", path)) |
| } else if(path == "/doc/html/rw-FAQ.html") { |
| file <- file.path(R.home("doc"), sub("^/doc", "", path)) |
| if(file.exists(file)) |
| list(file = file, "content-type" = mime_type(path)) |
| else { |
| url <- "https://cran.r-project.org/bin/windows/base/rw-FAQ.html" |
| return(list(payload = paste0('Redirect to <a href="', url, '">"', |
| url, '"</a>'), |
| "content-type" = 'text/html', |
| header = paste0('Location: ', url), |
| "status code" = 302L)) # temporary redirect |
| } |
| } else if(grepl("doc/html/.*html$" , path) && |
| file.exists(tmp <- file.path(tempdir(), ".R", path))) { |
| ## use updated version, e.g. of packages.html |
| list(file = tmp) |
| } else if(grepl("doc/manual/.*html$" , path)) { |
| file <- file.path(R.home("doc"), sub("^/doc", "", path)) |
| if(file.exists(file)) |
| list(file = file, "content-type" = mime_type(path)) |
| else if(file.exists(file <- sub("/manual/", "/html/", file))) { |
| ## tarball has pre-built version of R-admin.html |
| list(file = file, "content-type" = mime_type(path)) |
| } else { |
| ## url <- "https://cran.r-project.org/manuals.html" |
| version <- |
| if(grepl("unstable", R.version$status)) "r-devel" else "r-patched" |
| url <- file.path("https://cran.r-project.org/doc/manuals", |
| version, basename(path)) |
| return(list(payload = paste0('Redirect to <a href="', url, '">"', |
| url, '"</a>'), |
| "content-type" = 'text/html', |
| header = paste0('Location: ', url), |
| "status code" = 302L)) # temporary redirect |
| } |
| } else { |
| if(startsWith(path, "/doc/")) { |
| ## /doc/AUTHORS and so on. |
| file <- file.path(R.home("doc"), sub("^/doc", "", path)) |
| } else return(error_page(gettextf("unsupported URL %s", mono(path)))) |
| if(!file.exists(file)) |
| error_page(gettextf("URL %s was not found", mono(path))) |
| else |
| list(file = file, "content-type" = mime_type(path)) |
| } |
| } |
| |
| ## 0 = untried, < 0 = failed to start, > 0 = actual port |
| httpdPort <- local({ |
| port <- 0L |
| function(new) { |
| if(!missing(new)) |
| port <<- new |
| else |
| port |
| } |
| }) |
| |
| startDynamicHelp <- function(start = TRUE) |
| { |
| if(nzchar(Sys.getenv("R_DISABLE_HTTPD"))) { |
| httpdPort(-1L) |
| warning("httpd server disabled by R_DISABLE_HTTPD", immediate. = TRUE) |
| utils::flush.console() |
| return(invisible(httpdPort())) |
| } |
| |
| port <- httpdPort() |
| if (is.na(start)) { |
| if(port <= 0L) return(startDynamicHelp(TRUE)) |
| return(invisible(port)) |
| } |
| if (start && port) { |
| if(port > 0L) stop("server already running") |
| else stop("server could not be started on an earlier attempt") |
| } |
| if(!start && (port <= 0L)) |
| stop("no running server to stop") |
| if (start) { |
| utils::flush.console() |
| OK <- FALSE |
| ports <- getOption("help.ports") |
| if (is.null(ports)) { |
| ## Choose 10 random port numbers between 10000 and 32000. |
| ## The random seed might match |
| ## on multiple instances, so add the time as well. But the |
| ## time may only be accurate to seconds, so rescale it to |
| ## 5 minute units. |
| ports <- 10000 + 22000*((stats::runif(10) + unclass(Sys.time())/300) %% 1) |
| } |
| ports <- as.integer(ports) |
| if (all(ports == 0)) |
| return(invisible(0)) |
| message("starting httpd help server ...", appendLF = FALSE) |
| for(i in seq_along(ports)) { |
| ## the next can throw an R-level error, |
| ## so do not assign port unless it succeeds. |
| status <- .Call(C_startHTTPD, "127.0.0.1", ports[i]) |
| if (status == 0L) { |
| OK <- TRUE |
| httpdPort(ports[i]) |
| break |
| } |
| if (status != -2L) break |
| ## so status was -2, which means port in use |
| } |
| if (OK) { |
| message(" done") |
| utils::flush.console() |
| ## FIXME: actually test the server |
| } else { |
| warning("failed to start the httpd server", immediate. = TRUE) |
| utils::flush.console() |
| httpdPort(-1L) |
| } |
| } else { |
| ## Not really tested |
| .Call(C_stopHTTPD) |
| httpdPort(0L) |
| } |
| invisible(httpdPort()) |
| } |
| |
| dynamicHelpURL <- |
| function(path, port = httpdPort()) |
| paste0("http://127.0.0.1:", port, path) |
| |
| ## environment holding potential custom httpd handlers |
| .httpd.handlers.env <- new.env() |
| |
| .httpd_objects <- |
| local({ |
| val <- list() |
| function(port, new) { |
| port <- as.character(port) |
| if(!missing(new)) |
| val[[port]] <<- new |
| else |
| val[[port]] |
| } |
| }) |
