R/catmaid_connection.R

In jefferis/rcatmaid: R access to the API for the CATMAID web image annotation tool

#' Connect/authenticate to a CATMAID server, returning a connection object
#' 
#' @description \code{catmaid_login} allows you to login to a CATMAID server 
#'   specified by a \code{catmaid_connection} object. If such an object is not 
#'   specified, then the last successful connection in this R session is reused 
#'   if possible otherwise a new connection object is created using 
#'   \code{options} of the form "catmaid.\*" or "catmaid_\*" (see details).
#'   
#'   The connection object returned by \code{catmaid_login} (or cached when 
#'   \code{Cache=TRUE}, the default) can then be used for future requests to the
#'   CATMAID server by get/query/fetch functions.
#'   
#' @details After successful login, the \code{catmaid_connection} object will 
#'   contain a \code{cookie} field that includes a sessionid that is required 
#'   for subsequent GET/POST operations.  When \code{Cache=TRUE} (the default) 
#'   the open connection object is cached and will be used when EITHER 
#'   \code{catmaid_login} is called with enough information to indicate that the
#'   same server is desired OR (when no information about the server is passed 
#'   to \code{catmaid_login}) the last opened connection will be used.
#'   
#' @section Token based authentication: CATMAID offers token based 
#'   authentication as the strongly preferred alternative to specifying you
#'   CATMAID username and password. See
#'   \url{http://catmaid.github.io/dev/api.html#api-token} for how to get an API
#'   token. You can then set the \code{catmaid.token} or \code{catmaid_token} package option, but no
#'   longer need to set the \code{catmaid.username} or \code{catmaid_username} and \code{catmaid.password} or \code{catmaid_password}
#'   options.
#'   
#'   Note that you must \bold{NOT} reveal this token e.g. by checking it into a 
#'   version controlled script as it gives complete access to your CATMAID 
#'   account.
#'   
#' @param conn An optional \code{catmaid_connection} connection object.
#' @param ... Additional arguments passed to catmaid_connection
#' @param Cache Whether to cache open connections at login so that they can be 
#'   reused automatically.
#' @param Force Whether to force a new login to the CATMAID server (default 
#'   \code{FALSE})
#'   
#' @return a \code{catmaid_connection} object that can be used to make 
#'   authenticated http requests to a CATMAID server, specifically by making use
#'   of the \code{$config} field.
#'   
#' @section Environment variables:
#'   
#'   You will very likely want to set the following environment variables in 
#'   your \code{.Renviron} file (see \code{\link{Startup}} for details). This 
#'   file is read by R on startup. In this way the catmaid package will 
#'   automatically login to your preferred CATMAID server. Note that environment
#'   variables will also be inherited by child R sessions. This means for
#'   example that they will be available when running knitr reports, tests or R
#'   CMD Check from Rstudio.
#'   
#'   \itemize{
#'   
#'   \item{\code{catmaid.server} or \code{catmaid_server}}
#'   
#'   \item{\code{catmaid.token} or \code{catmaid_token}} Preferred to using catmaid.username/password
#'   
#'   \item{\code{catmaid.authname} or \code{catmaid_authname}} Optional username for basic http website 
#'   authorisation
#'   
#'   \item{\code{catmaid.authpassword} or \code{catmaid_authpassword}} Optional password for basic http website
#'   authorisation
#'
#'   \item{\code{catmaid.username} or \code{catmaid_username}} Your catmaid username (deprecated in favour 
#'   of token)
#'   
#'   \item{\code{catmaid.password} or \code{catmaid_password}} Your catmaid password (deprecated in favour 
#'   of token)
#'   
#'   } An example \code{.Renviron} file might look like (the periods(.) in the environmental variable name can be also replaced
#'   with underscore(_) as mentioned above:
#'   
#'   \preformatted{
#'catmaid.server="https://mycatmaidserver.org/catmaidroot"
#'catmaid.token="9944b09199c62bcf9418ad846dd0e4bbdfc6ee4b"
#'catmaid.authname="Calvin"
#'catmaid.authpassword="hobbes"
#'   }
#'   
#'   and \bold{must} finish with a return at the end of the last line. See
#'   \url{http://catmaid.github.io/dev/api.html#api-token} for details of 
#'   obtaining an API token
#'   
#' @section Options: Although setting environment variables is now the recommended 
#'   approach, you can also set R startup options e.g. in your \code{.Rprofile}
#'   to specify default CATMAID login options including your personal access 
#'   token. The startup options have the same names as the environment variables
#'   listed above, so you can place code along the lines of:
#'   
#'   \code{options(catmaid.server="https://mycatmaidserver.org/catmaidroot", 
#'   catmaid.authname="Calvin",catmaid.authpassword="hobbes", catmaid.token = 
#'   "9944b09199c62bcf9418ad846dd0e4bbdfc6ee4b")}
#'   
#'   in your \code{.Rprofile} (see \code{\link{Startup}} for details). Note that
#'   it is important to have a final return at the end of your \code{.Rprofile}
#'   file.
#'   
#' @seealso \code{\link{options}}, \code{\link{Startup}},
#'   \code{\link{vfbcatmaid}}
#' @export
#' @examples
#' # but see vfbcatmaid() convenience function
#' catmaid_login(server="https://l1em.catmaid.virtualflybrain.org")
#' 
#' \dontrun{
#' ## example explicitly specifying connection options
#' # using modern token based authentication
#' conn = catmaid_login(server="https://mycatmaidserver.org/catmaidroot",
#'   authname="Calvin",authpassword="hobbes", 
#'   token="9944b09199c62bcf9418ad846dd0e4bbdfc6ee4b")
#'   
#' # ... or using the old fashioned approach specifiy username/password
#' conn = catmaid_login(server="https://mycatmaidserver.org/catmaidroot",
#'   authname="Calvin",authpassword="hobbes", 
#'   username="calvin", password="hobbesagain")
#' 
#' ## examples assuming that catmaid.* environment variables/options are set
#' conn = catmaid_login()
#' conn = catmaid_login(server='https://someotherserver.org/catmaidroot')
#' 
#' ## set additional curl options/headers
#' # This example will bypass an SSL certificate verification error on the
#' # remote host e.g. if it has expired. Don't this regularly of course!
#' conn = catmaid_login(config=httr::config(ssl_verifypeer=0))
#' # This example will allow you to change the http protocol version while connecting!
#' # Changing the http version is useful when encountering curl related errors 
#' conn = catmaid_login(config=httr::config(http_version=1))
#' 
#' ## now do stuff with the connection like
#' skel=catmaid_fetch("1/10418394/0/0/compact-skeleton", conn=conn)
#' # you can also omit the connecttion because it will be cached and reused
#' skel=catmaid_fetch("1/10418394/0/0/compact-skeleton")
#' 
#' ## or for those who want to work at the lowest level
#' skel2=GET("https://mycatmaidserver.org/catmaidroot/1/10418394/0/0/compact-skeleton",
#'   config=conn$config)
#' }
catmaid_login<-function(conn=NULL, ..., Cache=TRUE, Force=FALSE){
  if(is.character(conn) && grepl("^http", conn)) {
    # this looks like a server, probably because we are trying to connect to 
    # without other login details
    stop("To connect to : ", conn, ", you must name the server argument i.e.\n",
         sprintf('  catmaid_login(server="%s")', conn)) 
  }
  if(is.null(conn)) {
    if(!length(pairlist(...))) {
      # try and get the last cached connection
      conn=catmaid_last_connection()
    }
    if(is.null(conn))
      conn=catmaid_connection(...)
  }
  
  # check if we can use this connection already or reuse a cached one
  if(!Force) {
    # already open if authresponse exists
    if(!is.null(conn$authresponse)) 
      return(invisible(conn))
    cached_conn=catmaid_cached_connection(conn)
    if(!is.null(cached_conn))
      return(invisible(cached_conn))
  }
  if(isTRUE(conn$nologin)) {
    # GET the CATMAID root for 2 reasons
    # 1. this checks that it actually exists
    # 2. we need to collect a CSRF token
    conn$authresponse=GET(url=conn$server)
    stop_for_status(conn$authresponse)
    
    # Now assuming that we could talk to the server we need to extract the CSRF
    # token. But it turns out that we need to pass the token twice
    # 1. once with the Cookie: header
    # 2. a second time we need to pass just the value with the X-CSRFToken header
    # Step 1 is handled generically for any kind of authresponse lower down
    # but Step 2 needs some special logic here
    res_cookies=cookies(conn$authresponse)
    csrf_row=grepl('csrf', res_cookies$name)
    if(any(csrf_row)) {
      token_value=res_cookies$value[csrf_row][1]
      conn$config=httr::add_headers('X-CSRFToken'=token_value, referer=conn$server)
    } else warning("I can't seem to find a CSRF token.",
              "You will not be able to POST to this site!")
  } else { 
    body <- if(is.null(conn$token))
      list(name=conn$username, pwd=conn$password) else NULL
    conn$authresponse = POST(url = paste0(conn$server, "/accounts/login"), 
                             body=body,
                             config = conn$config)
    stop_for_status(conn$authresponse)
  }
  
  # store the returned cookies for future use
  conn$cookies=unlist(cookies(conn$authresponse))
  conn$config=c(conn$config, set_cookies(conn$cookies))
  if(Cache)
    catmaid_cache_connection(conn)
  conn
}

#' @name catmaid_login
#' @description \code{catmaid_connection} is a lower level function used by
#'   \code{catmaid_login} to create a connection object. End users should not
#'   need to call this directly, but it does document the arguments that can be
#'   used to specify a connection to a CATMAID server.
#' @param server url of CATMAID server
#' @param username,password Your CATMAID username and password.
#' @param token An API token (A modern alternative to providing your CATMAID
#'   username and password). See \bold{Token based authentication} for details.
#' @param authname,authpassword The http username/password that optionally
#'   secures the CATMAID website. These are not the same as your CATMAID login
#'   details.
#' @param authtype The http authentication scheme, see
#'   \code{\link[httr]{authenticate}} for details.
#' @param config Additional curl config options. See \code{\link[httr]{config}}
#'   for details and the examples section below.
#' @details Note the difference between \code{authname}/\code{authpassword} and
#'   \code{username}/\code{password}. The former are for generic web
#'   authentication, which is sometimes used to protect a private catmaid site
#'   from being accessible to general web traffic. The latter are used to
#'   authenticate to the CATMAID web application itself - for example the
#'   \code{username} is the one that will be associated with any tracing carried
#'   out by you in CATMAID.
#' @export
catmaid_connection<-function(server, username=NULL, password=NULL, authname=NULL, 
                             authpassword=NULL, token=NULL,
                             authtype=NULL, config=NULL) {
  # a bit of juggling to figure out which args could be passed and which
  # actually have been passed explicitly
  arglist=formals(fun = sys.function())
  argnames=names(arglist)
  m=match.call(definition = sys.function(), call = sys.call())
  passed_args=names(m[-1])
  
  # Set a default server if none specified
  defaultServer=unlist(getenvoroption("server"))
  if(missing(server)) {
    server=defaultServer
  }
  
  # construct basic connection list
  conn=list(server=server,
            username=username,
            password=password,
            authname=authname,
            authpassword=authpassword,
            token=token,
            authtype=authtype)[union("server", passed_args)]
  class(conn)="catmaid_connection"

  
  if(is.null(conn$server) || !grepl("^http[s]{0,1}", conn$server))
    stop("Must provide a valid https server")

  # Fill in the missing values using environment vars or options
  if(isTRUE(unname(conn$server==defaultServer))){
    missing_vars=setdiff(argnames, names(m))
    conn[missing_vars]=getenvoroption(missing_vars)
  }
  
  if(is.null(conn$username) && is.null(conn$token)) {
    conn$nologin=TRUE
    return(invisible(conn))
  }
  
  # make a curl config that includes any settings passed in 
  conn$config=c(config(), config)
  # then add authentication information if necessary
  if (!is.null(conn$authname)) {
    if (is.null(conn$authtype))
      conn$authtype = 'basic'
    conn$config = c(conn$config,
                    authenticate(conn$authname, conn$authpassword, type = conn$authtype))
  }
  if (!is.null(conn$token))
    conn$config = c(conn$config,
                    add_headers(`X-Authorization` = paste("Token", conn$token)))
  invisible(conn)
}

getenvoroption <- function(vars){
  fullvars=paste0(catmaid_envstr(), vars)
  res=Sys.getenv(fullvars, names = T, unset = NA)
  if(all(is.na(res))){
    # no env variables are set, let's try options
    res=do.call(options, as.list(fullvars))
  } else {
    # convert environment variables into options style list
    res=as.list(res)
    # replace missing values with NULL
    res=sapply(res, function(x) if(is.na(x)) NULL else x)
  }
  # give result the original variable names
  names(res)=vars
  res
}

#' Send http GET or POST request to a CATMAID server
#' 
#' @description \code{catmaid_fetch} carries out a GET operation when 
#'   \code{body=NULL}, POST otherwise. The http status code of the response will
#'   be checked - if invalid an error will be thrown.
#'   
#' @param path The path on the CATMAID server relative to the CATMAID root
#' @param body The (optional) body of the post request, usually in the form of a
#'   named list. See the \code{\link[httr]{POST}} documentation for full 
#'   details.
#' @param conn A \code{catmaid_connection} objection returned by 
#'   \code{\link{catmaid_login}}. If \code{NULL} (the default) a new connection 
#'   object will be generated using the values of the \bold{catmaid.*} package 
#'   options as described in the help for \code{\link{catmaid_login}}.
#' @param parse.json Whether or not to parse a JSON response to an R object 
#'   (default \code{TRUE})
#' @param include_headers Whether to include basic headers from the http request
#'   as attributes on the parsed JSON object (default \code{TRUE}) when 
#'   \code{parse.json=TRUE}.
#' @param simplifyVector Whether to use jsonlite::simplifyVector 
#' @param ... Additional arguments passed to the \code{httr::GET} or 
#'   \code{httr::POST} function
#' @return When \code{parse.json=FALSE} an object of class \code{response} 
#'   otherwise the raw R object generated by calling 
#'   \code{jsonlite::\link[jsonlite]{fromJSON}} on the body of the response.
#' @export
#' @seealso \code{\link{catmaid_login}}, \code{\link[httr]{GET}}, 
#'   \code{\link[httr]{POST}}
#' @importFrom jsonlite fromJSON
#' @examples
#' \dontrun{
#' ## Make a catmaid_connection object to use for these requests
#' conn=catmaid_login()
#' 
#' ## fetch a demo skeleton using a GET request
#' # raw response
#' skel.response=catmaid_fetch("1/10418394/0/0/compact-skeleton", conn=conn)
#' # list object
#' skel=catmaid_fetch("1/10418394/0/0/compact-skeleton", conn=conn)
#' 
#' ## Get the names of two skeletons using a POST request
#' # NB that the skids[n] elements are quoted when constructing the list since 
#' # they are not valid R names.
#' catmaid_fetch("/1/skeleton/neuronnames", conn=conn,
#'   body=list(pid=1, 'skids[1]'=10418394, 'skids[2]'=4453485))
#' 
#' ## get all skeletons with more than 1000 nodes
#' skids=as.integer(catmaid_fetch("/1/skeletons/?nodecount_gt=1000"))
#' 
#' ## fetch user history since 1st April 2016
#' uh = catmaid_fetch('1/stats/history?start_date=2016-04-01', 
#'   simplifyVector = T, include_headers = F)
#' uh$date=as.Date(uh$date,"%Y%m%d")
#' library(dplyr)
#' # select top 10 users by nodes added
#' top10=uh %>% 
#'   group_by(name) %>% 
#'   summarise(total=sum(count)) %>% 
#'   arrange(desc(total)) %>%
#'   top_n(10)
#' # plot cumulative nodes traced
#' library(ggplot2)
#' uh %>% 
#'   group_by(name) %>%
#'   mutate(ccount = cumsum(count)) %>%
#'   filter(name %in% top10$name) %>% 
#'   ggplot(aes(date, ccount, col = name)) + geom_line()
#' 
#' ## demonstrate that bad urls will result in an error
#' catmaid_fetch("/1/rhubarb/crumble")
#' }
catmaid_fetch<-function(path, body=NULL, conn=NULL, parse.json=TRUE, 
                        include_headers=TRUE, simplifyVector=FALSE, ...) {
  conn=catmaid_login(conn)
  req<-with_config(conn$config, {
    if(is.null(body)) {
      GET(url=file.path(conn$server, path, fsep="/"), ...)
    } else {
      POST(url=file.path(conn$server, path, fsep="/"), body=body, ...)
    }
  } )
  # error out if there was a problem
  stop_for_status(req)
  if(parse.json) {
    parsed=catmaid_parse_json(req, simplifyVector=simplifyVector)
    if(length(parsed)==2 && isTRUE(names(parsed)[2]=='error')) {
      stop("catmaid error: " , parsed$error)
    }
    if(include_headers) {
      fields_to_include=c("url", "headers")
      attributes(parsed) = c(attributes(parsed), req[fields_to_include])
    }
    parsed
  } else req
}

catmaid_parse_json <- function(req, simplifyVector = FALSE, ...) {
  text <- content(req, as = "text", encoding = "UTF-8")
  if (identical(text, "")) stop("No output to parse", call. = FALSE)
  fromJSON(text, simplifyVector = simplifyVector, ...)
}

# return the open cached connection object for an (unopened) connection
# returns NULL when passed NULL
# returns incoming connection if already opened
catmaid_cached_connection<-function(conn) {
  if(is.null(conn)) return(NULL)
  
  open_connections=names(.package_statevars$connections)
  if(!length(open_connections)) return(NULL)
  
  for(thisconn in open_connections) {
    thisconn=.package_statevars$connections[[thisconn]]
    checkfields=c("server","username","authname", "authtype")
    # drop any fields where the incoming connection does not contain info
    checkfields=checkfields[!sapply(conn[checkfields], is.null)]
    if(isTRUE(all.equal(thisconn[checkfields], conn[checkfields])))
      return(thisconn)
  }
  return(NULL)
}

catmaid_cache_connection<-function(conn) {
  .package_statevars$connections[[catmaid_connection_fingerprint(conn)]]=conn
}

catmaid_last_connection<-function() {
  conns=.package_statevars$connections
  num_conns=length(conns)
  if(num_conns) conns[[num_conns]] else NULL
}

# fingerprint of a connection consisting of server, username and cookies
catmaid_connection_fingerprint<-function(conn) {
  paste(c(conn$server, conn$username, cookies(conn$authresponse)), collapse = "")
}

#' Import/Export catmaid connection details to system variables (e.g. for tests)
#'
#' @description \code{catmaid_connection_setenv} sets environment variables
#'   based on a \code{catmaid_connection} object.
#'
#' @param conn A \code{catmaid_connection} object. The default value of NULL
#'   implies that the most recent cached open connection will be used.
#' @param ... additional arguments passed to \code{catmaid_login}
#' @details \code{catmaid_connection_setenv} will attempt to login if this has
#'   not already been done
#' @return \code{catmaid_connection_setenv} returns TRUE or FALSE depending on
#'   whether variables were set successfully. \code{catmaid_connection_getenv}
#'   returns a connection object created based on environment variables.
#' @seealso \code{\link{catmaid_login}}
#' @export
catmaid_connection_setenv<-function(conn=NULL, ...) {
  conn=catmaid_login(conn, ...)
  poss_vars_to_export=c("server", "username", "password", 
                        "authname", "authpassword", "authtype", "token")
  vars_to_export=intersect(poss_vars_to_export, names(conn))
  export_vector=unlist(conn[vars_to_export])
  names(export_vector)=paste0(catmaid_envstr(),  names(export_vector))
  all(do.call(Sys.setenv, as.list(export_vector)))
}

#' @description  #' \code{catmaid_connection_getenv} fetches appropriately named
#'   environment variables and returns them as named character vector.
#' @rdname catmaid_connection_setenv
#' @export
#' @importFrom stats na.omit
catmaid_connection_getenv<-function() {
  varnames=c("server", "username", "password", 
             "authname", "authpassword", "authtype", "token")
  catmaid_envnames=paste0(catmaid_envstr(), varnames)
  catmaid_envs=Sys.getenv(catmaid_envnames, unset = NA_character_)
  names(catmaid_envs)=varnames
  # drop any empty vars
  catmaid_envs=na.omit(catmaid_envs)
}

#' @description \code{catmaid_connection_unsetenv} unsets (or removes) the environment
#'   variables.
#' @rdname catmaid_connection_setenv
#' @export
catmaid_connection_unsetenv<-function(){
  vars=paste0(catmaid_envstr(),
              c("server", "username", "password", "authname", 
                "authpassword", "authtype", "token"))
  Sys.unsetenv(vars)
}


#' Return the CATMAID version running on the server
#' 
#' @details By default the version number for the current 
#'   \code{\link{catmaid_connection}} is stored on the first request after a new
#'   login and then the cached version number is reused. Setting 
#'   \code{cached=FALSE} will always force a request to the server.
#'   
#'   CATMAID versions are now produced by \bold{git describe} and look like 
#'   YYYY.MM.DD-XX-gaaaaaaa where aaaaaaa is a short SHA1 hash and XX is an 
#'   integer number of revisions since the last base version. Setting
#'   \code{numeric=TRUE} trims off the SHA1 hash leaving a string that can be
#'   interpreted as a four part version number (see examples).
#' @param conn A \code{catmaid_connection} object. The default value of NULL 
#'   implies that the most recent cached open connection will be used.
#' @param cached Whether to use the cached version number for this connection 
#'   (see details)
#' @param numeric Whether to parse the version string into an R 
#'   \code{numeric_version} object that can be used for comparisons.
#' @param ... Additional arguments passed to \code{\link{catmaid_fetch}}
#' @export
#' @return A character vector containing the version
#' @seealso \code{\link{numeric_version}}
#' @examples
#' \dontrun{
#' # example of checking if server version is newer than required version
#' catmaid_version(numeric=TRUE)>="2016.1.1-65"
#' }
catmaid_version <- function(conn=NULL, cached=TRUE, numeric=FALSE, ...) {
  conn=catmaid_login(conn = conn)
  version_regex="(-dev){0,1}-g[a-f0-9]{6,}$"
  if(!isTRUE(cached) || is.null(conn$catmaid.version)) {
    res=catmaid_fetch("/version", include_headers = F, simplifyVector = T, 
                      conn=conn, ...)
    # we just need the first return value
    conn$catmaid.version=res[[1]]
    nv <- try(numeric_version(sub(version_regex, "", conn$catmaid.version)),
              silent = TRUE)
    if(inherits(nv, 'try-error')){
      warning("CATMAID version: ", conn$catmaid.version, " could not be parsed!\n",
              "I will assume that you are running the latest version of CATMAID!")
      conn$catmaid.version <- "9999.12.31"
    }
    catmaid_cache_connection(conn)
  }
  if(!numeric){
    conn$catmaid.version
  } else {
    numeric_version(sub(version_regex, "", conn$catmaid.version))
  }
}

set_catmaid_version <- function(version, conn=NULL, ...) {
  catmaid_version(conn=conn)
  conn=catmaid_login(conn)
  conn$catmaid.version=version
  catmaid_cache_connection(conn)
}

#This local function returns the string to be used in matching the environment variable..
# either catmaid_ or catmaid.
catmaid_envstr <- function(){
  tempstr <- paste0("^", "catmaid", "(\\.|_)") #searching for strings beginning with catmaid_ or catmaid.
  matchvalues <- grep(pattern = tempstr, x = names(Sys.getenv()), value = TRUE)
  
  if (length(grep(pattern = paste0("^", "catmaid", "\\.") , x= matchvalues)) >= 1) {
    return("catmaid.")
  } else if (length(grep(pattern = paste0("^", "catmaid", "_") , x= matchvalues)) >= 1) {
    return("catmaid_")
  }else if (length(grep(pattern = paste0("^", "catmaid", "\\.") , x= matchvalues)) == 0 && 
            length(grep(pattern = paste0("^", "catmaid", "_") , x= matchvalues)) == 0) {
    simpleMessage("catmaid message: No usable environment variables found")
  } 
  else stop(paste("\ncatmaid error: Only found the environment variable -- ", matchvalues))
}

#' @export
#' @rdname catmaid_login
#' @param x A \code{catmaid_connection} object to print
#' @description \code{print.catmaid_connection} provides a convenient summary of
#'   the status of a \code{catmaid_connection}.
print.catmaid_connection <- function(x, ...) {
  cat("Connection to catmaid server:\n  ",
      x$server, sep="", "\n")
  # if(!is.null(x$dataset))
  #   cat("with default dataset:\n  ", x$dataset, "\n")
  if(!is.null(x$authresponse)) {
    cat("Login active since:", httr::headers(x$authresponse)$date)
  } else {
    cat("No active login")
  }
  invisible(x)
}