Support packages with different name than repo

R/apps.R

@@ -27,10 +27,12 @@ install_apps <- function(repo, ...){
 
 install_apps_one <- function(repo, ...){
   info <- ocpu_app_info(repo)
+  github_info <- github_package_info(url_path(info$user, info$repo))
+  package <- github_info$package
   lib <- info$path
   if(!file.exists(lib)){
     dir.create(lib)
-    pkgpath <- file.path(lib, info$pkg)
+    pkgpath <- file.path(lib, package)
     on.exit({
       if(!file.exists(pkgpath)){
         unlink(lib, recursive = TRUE)
@@ -40,6 +42,7 @@ install_apps_one <- function(repo, ...){
   }
   inlib(lib, {
     devtools::install_github(repo, force = TRUE, ...)
+    writeLines(package, file.path(lib, "_APP_"))
   })
 }
 
@@ -49,19 +52,26 @@ remove_apps <- function(repo){
   lapply(repo, function(full_name){
     info <- ocpu_app_info(full_name)
     # cannot remove loaded packages
-    try(unloadNamespace(info$pkg))
+    try(unloadNamespace(info$package))
     unlink(info$path, recursive = TRUE)
   })
 }
 
 ocpu_app_info <- function(repo){
   parts <- strsplit(repo[1], "[/@#]")[[1]]
   user <- parts[1]
-  pkg <- parts[2]
-  path <- github_userlib(user, pkg)
+  reponame <- parts[2]
+  path <- github_userlib(user, reponame)
+  appfile <- file.path(path, "_APP_")
+  package <- if(file.exists(appfile)){
+    readLines(appfile, n = 1L)[1]
+  } else {
+    reponame
+  }
   data.frame (
     user = user,
-    pkg = pkg,
+    repo = reponame,
+    package = package,
     path = path,
     installed = file.exists(path),
     stringsAsFactors = FALSE

R/github.R

@@ -18,6 +18,18 @@ github_userlib <- function(gituser, gitrepo){
   file.path(github_rootpath(), paste(github_prefix, gituser, gitrepo, sep="_"))
 }
 
+github_package_info <- function(repo){
+  tryCatch({
+  url <- sprintf("https://raw.githubusercontent.com/%s/master/DESCRIPTION", repo)
+  con <- curl::curl(url, open = "r")
+  on.exit(close(con))
+  out <- as.list(as.data.frame(read.dcf(con), stringsAsFactors = FALSE))
+  }, error = function(e){
+    stop(sprintf("Failed to read %s. Repsitory does not contain a proper R package.", url))
+  })
+  setNames(out, tolower(names(out)))
+}
+
 github_install <- function(repo, username, ref = "master", args = NULL, upgrade_dependencies = FALSE, ...){
   #get args
   all_args <- list(...)
@@ -38,6 +50,11 @@ github_install <- function(repo, username, ref = "master", args = NULL, upgrade_
   gittmpdir <- tempfile("githubdir")
   stopifnot(dir.create(gittmpdir))
 
+  # Download metadata before actually installing. Errors if no DESCRIPTION exists.
+  app_info <- github_package_info(all_args$repo)
+  package <- app_info$package
+  writeLines(package, file.path(gittmpdir, "_APP_"))
+
   #all_args$args <- paste0("'--library=", gittmpdir, "'")
 
   #Override auth_token if set in key
@@ -53,21 +70,22 @@ github_install <- function(repo, username, ref = "master", args = NULL, upgrade_
   });
 
   #We require package name with identical repo name
-  success <- isTRUE(file.exists(file.path(gittmpdir, repo)));
+  success <- isTRUE(file.exists(file.path(gittmpdir, package)))
 
   #The index.html for vignettes is useless due to hardcoded hyperlinks
-  unlink(file.path(gittmpdir, repo, "doc", "index.html"));
+  unlink(file.path(gittmpdir, package, "doc", "index.html"))
 
-  #move everything to new location
+  #move to permanent location
   if(success){
-    unlink(gitpath, recursive=TRUE)
+    unlink(gitpath, recursive = TRUE)
     stopifnot(dir.move(gittmpdir, gitpath))
   }
 
   #return success and output
   list(
     success = success,
     output = output,
-    gitpath = gitpath
-  );
+    gitpath = gitpath,
+    package = package
+  )
 }

R/httpget_github.R

@@ -27,10 +27,19 @@ httpget_github <- function(uri){
     res$sendlist(sub(pattern, "", pkglist))
   }
 
-  libpath <- github_userlib(gituser, gitrepo)
-  pkgpath <- file.path(libpath, gitrepo)
+  #check if app is installed
+  app_info <- ocpu_app_info(url_path(gituser, gitrepo))
+  if(!isTRUE(app_info$installed))
+    res$error(sprintf("Github App %s/%s not installed on this server", gituser, gitrepo), 404)
+
+  # For packages with different pkg name than repo name
+  libpath <- app_info$path
+  package <- app_info$package
+
+  # Name of package inside library
+  pkgpath <- file.path(libpath, package)
   if(!file.exists(pkgpath))
-    res$error(sprintf("Github package %s/%s not installed on this server", gituser, gitrepo), 404)
+    res$error(sprintf("Github package %s not foud in app library %s/%s.", package, gituser, gitrepo), 404)
   reqtail <- utils::tail(uri, -2)
 
   #set cache value

R/start.R

@@ -121,14 +121,15 @@ ocpu_start_server <- function(port = 5656, root ="/ocpu", workers = 2, preload =
 
 ocpu_start_app_github <- function(repo, ...){
   info <- ocpu_app_info(repo)
+  if(!info$installed){
+    install_apps(repo)
+    info <- ocpu_app_info(repo)
+  }
   gitpath <- info$path
   Sys.setenv(R_LIBS = gitpath)
   on.exit(Sys.unsetenv("R_LIBS"), add = TRUE)
-  # Install on the fly
-  if(!info$installed)
-    install_apps(repo)
   inlib(gitpath, {
-    start_server_with_app(info$pkg, file.path("apps", info$user), ...)
+    start_server_with_app(info$package, url_path("apps", info$user, info$repo), ...)
   })
 }
 
@@ -139,7 +140,7 @@ start_local_app_local <- function(package, ...){
 start_server_with_app <- function(package, path, ...){
   getNamespace(package)
   ocpu_start_server(..., preload = package, on_startup = function(server_address){
-    app_url <- file.path(server_address, path, package)
+    app_url <- url_path(server_address, path)
     log("Opening %s", app_url)
     utils::browseURL(app_url)
   })

R/utils.R

@@ -184,3 +184,7 @@ format_user_error <- function(e){
   }
   return(errmsg)
 }
+
+url_path <- function(...){
+  file.path(..., fsep = "/")
+}

examples/apps.R

@@ -2,12 +2,15 @@
 # List available demo apps
 available_apps()
 
-# Run application from: https://github.com/rwebapps/stocks
-ocpu_start_app("rwebapps/stocks")
+# Run application from: https://github.com/rwebapps/nabel
+ocpu_start_app("rwebapps/nabel")
 
 # Run application from: https://github.com/rwebapps/markdownapp
 ocpu_start_app("rwebapps/markdownapp")
 
+# Run application from: https://github.com/rwebapps/stockapp
+ocpu_start_app("rwebapps/stockapp")
+
 # Run application from: https://github.com/rwebapps/appdemo
 ocpu_start_app("rwebapps/appdemo")