R/applink.R

In kylebmetrum/linkapp: Deploy a shiny app locally to a shiny server

##' @importFrom yaml yaml.load_file
##' @importFrom R6 R6Class
NULL

key_file <- "_app-link-key_"

exclude_internal <- c(key_file)

write_key <- function(dir,key) cat(file=file.path(dir,key_file),key,sep="\n")

check_key <- function(app,to,from,key=NULL) {
  
  .to <- file.path(to,app,key_file)
  .from <- file.path(from,key_file)
  
  if(!file.exists(.to)) return(FALSE)
  
  if(!is.null(key)) {
    return(key==readLines(.to)[1]) 
  }
  
  if(!file.exists(.from)) return(FALSE)
  
  md <- tools::md5sum(c(.to,.from))
  
  return(md[1]==md[2])
}

is_error <- function(x) inherits(x,"try-error")

mod_dir_code <- 'sudo usermod -a -G shiny <username>;sudo chown -R <username>:shiny <app>;chmod -R g+rwx <app>'


##' Create and write .Rprofile
##' 
##' @param app app name
##' @param lib location of R packages
##' @param to the location of the shiny-server root
##' @param ... not used
##' @export
make_Rprofile <- function(app,lib=.libPaths()[1],to=file.path("data", "shiny-server"),...) {
  cmd <- paste0(".libPaths('",lib,"')")
  file <- file.path(to,app,".Rprofile")
  writeLines(cmd,file)
}

mod_dir <- function(app,to,from,user=Sys.getenv("USER"),...) {
  cwd <- getwd()
  on.exit(setwd(cwd))
  setwd(to)
  code <- gsub("<username>", user,mod_dir_code,fixed=TRUE)
  code <- gsub("<app>", app,code, fixed=TRUE)
  x <- try(system(code))
  if(is_error(x)) {
    stop("could not modify the app server directory") 
  }
  setwd(dirname(from))
  code <- gsub("<username>", user, mod_dir_code, fixed=TRUE)
  code <- gsub("<app>", app, code, fixed=TRUE)
  x <- try(system(code))
  if(is_error(x)) {
    stop("could not modify the app source directory") 
  }
}

init_dir <- function(app,to,from,key,...) {
  .to <- file.path(to,app)
  if(file.exists(.to)) {
    overwrite <- check_key(app,to,from,key)
    if(!overwrite) {
      stop("app directory (to) already exists; to overwrite files, please provide the correct key")
    }
  }
  if(file.exists(.to)) unlink(.to,recursive=TRUE)
  dir.create(.to)
  if(is.null(key)) key <- basename(tempfile(pattern="key"))
  write_key(.to,key)
  write_key(from,key)
  return(NULL)
}

make_links <- function(links=NULL,copies=NULL,app,to,
                       exclude=character(0),...) {
  to <- file.path(to,app)
  if(!is.null(links)) {
    links <- normalizePath(links,mustWork=FALSE)  
    if(!all(file.exists(links))) {
      ne <- paste(links[!file.exists(links)],collapse="\n")
      stop("Some files don't exist:\n",ne)
    }
    for(l in links) {
      file.symlink(l,to)
    }
  }
  if(!is.null(copies)) {
    copies <- normalizePath(copies,mustWork=FALSE)  
    if(!all(file.exists(copies))) {
      ne <- paste(copies[!file.exists(copies)],collapse="\n")
      stop("some files don't exist:\n",ne)
    }
    for(co in copies) {
      file.copy(co,to,recursive=TRUE)
    }
  }
}


read_manifest <- function(file,...) {
  requireNamespace("yaml")
  if(!grepl("\\.yaml$",file)) {
    stop("manifest must have .yaml extension") 
  }
  x <- yaml.load_file(file)
  has.copy <- "copy" %in% names(x)
  has.link <- "link" %in% names(x)
  if(!(has.copy | has.link)) {
    stop("no files listed to link or copy in manifest.") 
  }
  return(x)
}

##' Call link_app using a manifest file.
##' 
##' @param x the name of the manifest file
##' @param ... other parameters to pass to \code{\link{link_app}}
##' 
##' @details The manifest file must have \code{.yaml} extension.
##' 
##' @examples
##' 
##' # example manifest file
##' \dontrun{
##' name: myapp
##' link:
##'   - server.R
##'   - ui.R
##'   - app_data.csv
##' copy: 
##'   - report.Rmd
##' key: 
##'   - 22993lajdfa 
##' }
##' 
##' @export
link_app_file <- function(x,...) {
  x <- read_manifest(x)
  x <- c(list(...),x)
  x <- x[unique(names(x))]
  do.call(link_app,x) 
}

##' Link a Shiny app to shiny-server directory.
##' 
##' @param from the location (source directory) for the app
##' @param to the location (destination directory) for the shiny-server
##' @param link app files to simlink to destination app directory
##' @param copy app files to copy to destination app directory
##' @param name the app name
##' @param .Rprofile logical; if \code{TRUE}, an \code{.Rprofile} file will be 
##' established in destination app directory
##' @param .restart if \code{TRUE}, a \code{restart.txt} file will be created in the 
##' \code{to} directory
##' @param system_setup logical; see \code{details}
##' @param key a unique key for the app 
##' @param exclude files to exclude from both copying and symlinking
##' @param app_root root directory; \code{from} and \code{to} are relative to this directory
##' @param copy_in files to copy into the \code{from} directory prior to linking
##' @param quiet don't print progress messages
##' @param ... passed to \code{\link{make_Rprofile}}
##' 
##' @details
##' By default, \code{.libPaths} is set to \code{.libPaths()[1]}.  This can 
##' be manually set by passing the path as \code{lib}.
##' 
##' If \code{system_setup} is \code{TRUE}, the following system commands are run:
##' \itemize{
##' \item \code{sudo usermod -a -G shiny <username>}
##' \item \code{sudo chown -R <username>:shiny <name>}
##' \item \code{sudo chmod -R g+rwx <name>}
##' 
##' }
##' 
##' 
##' @examples
##' \dontrun{
##' link_app(".")
##' link_app("my_app_dir")
##' link_app_file("app.yaml")
##' }
##' @aliases linkapp
##' @export
link_app <- function(from = '.', 
                     to = getOption("applink_to","/data/shiny-server"),
                     link = NULL, copy = NULL, name = NULL, 
                     .Rprofile = TRUE,.restart = TRUE, system_setup = TRUE, key = NULL,
                     exclude = character(0), app_root = getwd(),
                     copy_in = NULL,
                     quiet = FALSE,...) {

  if(!dir.exists(from)) {
    stop("source (from) directory does not exist") 
  }
  if(!dir.exists(to)) {
    stop("destination (to) directory does not exist") 
  }
  
  cwd <- getwd()
  on.exit(setwd(cwd))
  setwd(app_root)
  
  from <- normalizePath(from)
  to <- normalizePath(to)
  

  if(is.null(name)) {
    name <- basename(from) 
  }
  if(is.null(copy) & is.null(link)) {
    link <- list.files(from,full.names=TRUE) 
  }
  if(is.null(copy)) copy <- character(0)
  if(is.null(link)) link <- character(0)
  exclude <- file.path(from,unique(c(exclude_internal,exclude)))
  copy <- setdiff(copy,exclude)
  link <- setdiff(link,exclude)
  if(!quiet) {
    message("deploying app: ", name)
    message("initializing app directory under ", to) 
  }
  init_dir(name,to,from,key)
  
  if(is.character(copy_in)) {
    copy_in <- normalizePath(copy_in)
    copy_in_dest <- file.path(from, basename(copy_in))
    file.copy(copy_in, copy_in_dest, overwrite = TRUE)
  }
  
  if(!quiet) {
    message("found ",length(link) + length(copy), " targets to deploy")
    message(" - linking ", length(link), " targets")
    message(" - copying ", length(copy), " targets")
  }
  make_links(link,copy,name,to,exclude)
  if(.Rprofile) {
    if(!quiet) message("building .Rprofile") 
    make_Rprofile(name,to=to,...)
  }  
  if(.restart) {
    if(!quiet) message("adding restart.txt file")
    cat("# generated by linkapp", file=file.path(to,name,"restart.txt"))
  }
  if(system_setup) mod_dir(name,to,from,...)
  message("the app is deployed under key ", 
          readLines(file.path(from,key_file))[1])
}