R/mica.R

In obiba/micar: 'Mica' Data Web Portal Client

#-------------------------------------------------------------------------------
# Copyright (c) 2019 OBiBa. All rights reserved.
#  
# This program and the accompanying materials
# are made available under the terms of the GNU Public License v3.0.
#  
# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.
#-------------------------------------------------------------------------------

#' Open a connection with Mica and returns a Mica object. When the two-factor
#' authentication mechanism is enabled, the user will be prompt for one-time password input. 
#' 
#' @title Open connection with Mica
#' 
#' @return A Mica object.
#' @param username User name in mica. Can be provided by "mica.username" option.
#' @param password User password in mica. Can be provided by "mica.password" option.
#' @param url Mica url or list of mica urls. Can be provided by "mica.url" option. Secure http (https) connection is required.
#' @param opts Curl options. Can be provided by "mica.opts" option.
#' @examples 
#' \dontrun{
#' # login using credentials from mica.username and mica.password options
#' m <- mica.login("https://mica-demo.obiba.org")
#' # login by providing credentials
#' m <- mica.login("administrator", "password", "https://mica-demo.obiba.org")
#' }
#' @export
mica.login <- function(username=getOption("mica.username", "anonymous"), password=getOption("mica.password", "password"), url=getOption("mica.url"), opts=getOption("mica.opts", list())) {
  if (is.null(url)) stop("mica url is required", call.=FALSE)
  micaUrl <- url
  if (startsWith(url, "http://localhost:8082")) {
    micaUrl <- gsub("http://localhost:8082", "https://localhost:8445", url)
    warning("Deprecation: connecting through secure http is required. Replacing http://localhost:8082 by https://localhost:8445.")
  } else if (startsWith(url, "http://")) {
    stop("Deprecation: connecting through secure http is required.")
  }
  urlObj <- httr::parse_url(micaUrl)
  
  mica <- new.env(parent=globalenv())
  # Username
  mica$username <- username
  # Strip trailing slash
  mica$url <- sub("/$", "", micaUrl)
  # Domain name
  mica$name <- urlObj$hostname
  # Version default value
  mica$version <- NA
  # Authorization
  mica$authorization <- .authToken(username, password)
  class(mica) <- "mica"
  
  options <- opts
  if (urlObj$hostname == "localhost" && length(options) == 0) {
    options <- list(ssl_verifyhost=F, ssl_verifypeer=F)
  }
  
  mica$httrConfig <- config()
  mica$httrConfig$options <- options
  r <- GET(.url(mica, "config"), config = mica$httrConfig, httr::add_headers(Authorization = mica$authorization), .verbose())
  if (httr::status_code(r) == 401) {
    headers <- httr::headers(r)
    optHeader <- headers[tolower('WWW-Authenticate')]
    if (optHeader == 'X-Obiba-TOTP') {
      # TOTP code is required
      code <- readline(prompt = 'Enter 6-digits code: ')
      r <- GET(.url(mica, "config"), config = mica$httrConfig, httr::add_headers(Authorization = mica$authorization, 'X-Obiba-TOTP' = code), .verbose())
    }
  }
  mica$config <- .handleResponse(mica, r)
  
  mica
}

#' Close connection and release resources of Mica.
#' 
#' @title Close connection with Mica
#' @param mica A Mica object
#' @examples 
#' \dontrun{
#' m <- mica.login("https://mica-demo.obiba.org")
#' mica.logout(m)
#' }
#' @export
mica.logout <- function(mica) {
  if (getOption("verbose", FALSE)) {
    r <- DELETE(.url(mica, "auth", "session", "_current"), config = mica$httrConfig, httr::verbose())
  } else {
    r <- DELETE(.url(mica, "auth", "session", "_current"), config = mica$httrConfig)
  }
  mica$sid <- NULL
}

#' @export
print.mica <- function(x, ...) {
  cat("url:", x$url, "\n")
  cat("name:", x$name, "\n")
  cat("version:", x$version, "\n")
  cat("username:", x$username, "\n")
  cat("session:", x$sid, "\n")
}

#' Extract label for locale. If not found, fallback to undefined language label (if any).
#' @keywords internal
.extractLabel2 <- function(locale="en", labels=list(), localeKey="locale", valueKey="text") {
  .extractLabel(locale, labels, localeKey=localeKey, valueKey=valueKey)
}

#' Extract label for locale. If not found, fallback to undefined language label (if any).
#' @keywords internal
.extractLabel <- function(locale="en", labels=list(), localeKey="lang", valueKey="value") {
  if (is.null(labels) || length(labels) == 0) {
    return(NA)
  }
  label <- NA
  label.und <- NA
  for (i in 1:length(labels)) {
    l <- labels[[i]]
    if (l[[localeKey]] == locale) {
      label <- l[[valueKey]]
    }
    if (l[[localeKey]] == "und") {
      label.und <- l[[valueKey]]
    }
  }
  if (is.na(label)) {
    label.und
  } else {
    label
  }
}

#' @keywords internal
.nullToNA <- function(x) {
  if (is.null(x)) {
    NA
  } else {
    x
  }
}

#' Display search result metrics
#' @keywords internal
.reportListMetrics <- function(results){
  if ("variableResultDto" %in% names(results)) {
    message("variables: ", results[["variableResultDto"]][["totalHits"]], "/", results[["variableResultDto"]][["totalCount"]])
  }
  if ("datasetResultDto" %in% names(results)) {
    message("datasets: ", results[["datasetResultDto"]][["totalHits"]], "/", results[["datasetResultDto"]][["totalCount"]])
  }
  if ("studyResultDto" %in% names(results)) {
    message("studies: ", results[["studyResultDto"]][["totalHits"]], "/", results[["studyResultDto"]][["totalCount"]])
  }
  if ("networkResultDto" %in% names(results)) {
    message("networks: ", results[["networkResultDto"]][["totalHits"]], "/", results[["networkResultDto"]][["totalCount"]])
  }
}

#' Flatten a list hierarchy
#' @keywords internal
.flatten <- function(content, locale="en") {
  rval <- list()
  flattenValue <- function(val) {
    ifelse(is.null(val), NA, ifelse(length(val)<2 && (is.logical(val) || is.numeric(val)), val, paste(val, collapse = "|")))
  }
  if (is.null(names(content))) {
    # a list, but not a named one
    for (i in 1:length(content)) {
      val <- content[[i]]
      if (!is.list(val)) {
        rval[[i]] <- flattenValue(val)
      } else {
        subct <- .flatten(val, locale)
        for (subn in names(subct)) {
          if (is.null(rval[[subn]])) {
            rval[[subn]] <- subct[[subn]]
          } else {
            rval[[subn]] <- paste0(rval[[subn]], "|", subct[[subn]])  
          }
        }
      }
    }
  } else {
    for (n in names(content)) {
      val <- content[[n]]
      if (!is.list(val)) {
        rval[[n]] <- flattenValue(val)
      } else if (length(val) == 0) {
        rval[[n]] <- NA
      } else {
        subct <- .flatten(val, locale)
        for (subn in names(subct)) {
          # localized value is attached to the parent node
          k <- ifelse(subn == locale, n,  paste0(n, ".", subn))
          rval[[k]] <- subct[[subn]]
        }
      }
    }  
  }
  rval
}

#' Verbose flag
#' @import httr
#' @keywords internal
.verbose <- function() {
  verbose <- NULL
  if (getOption("verbose", FALSE)) {
    verbose <- httr::verbose()
  }
  verbose
}

#' Issues a GET request to mica for the specified resource
#' @import httr
#' @keywords internal
.get <- function(mica, ..., query=list()) {
  r <- GET(.url(mica, ...), config = mica$httrConfig, query=query, .verbose())
  .handleResponse(mica, r)
}

#' Issues a POST form request to mica for the specified resource
#' @import httr
#' @keywords internal
.post <- function(mica, ..., query=list()) {
  r <- POST(.url(mica, ...), config = mica$httrConfig, body=query, encode=c("form"), .verbose())
  .handleResponse(mica, r)
}

#' Default request response handler.
#' @import httr
#' @keywords internal
.handleResponse <- function(mica, response) {
  if (is.null(mica$version) || is.na(mica$version)) {
    headers <- httr::headers(response)
    mica$version <- as.character(headers[tolower('X-Mica-Version')])
  }
  content <- content(response)
  if (response$status>=300) {
    if ("error" %in% names(content)) {
      if ("message" %in% names(content)) {
        stop(content$message, call.=FALSE)
      } else {
        stop(content$error, call.=FALSE)  
      }
    } else {
      stop(response$status, call.=FALSE)
    }
  }
  cookies <- httr::cookies(response)
  mica$sid <- .extractMicaSessionId(cookies)
  content
}

#' Extract micasid from cookie data frame.
#' @keywords internal
.extractMicaSessionId <- function(cookies) {
  if (nrow(cookies[cookies$name=="micasid",])>0) {
    sid <- cookies[cookies$name=="micasid",]$value
    if (!is.na(sid)) {
      return(sid)
    }
  }
  return(NULL)
}

#' Utility method to build urls. Concatenates all arguments and adds a '/' separator between each element
#' @keywords internal
.url <- function(mica, ...) {
  paste(mica$url, "ws", ..., sep="/")
}

#' Constructs the value for the Authorization header
#' @import jsonlite
#' @keywords internal
.authToken <- function(username, password) {
  paste("Basic", jsonlite::base64_enc(paste(username, password, sep=":")))
}