R/eruu_user.R

In pydupont/esr.redcap.user.ui: ESR recap user UI

source("R/eruu_generate_keys.R")

#' @export
min_password_score <- 2

#' Function: generate_password
#'
#' Generates a random password of given length
#'
#' @param length password length
#'
#' @return the password as characters
#'
#' @export
generate_password <- function(length = 32){
  possibles <- c(letters,
                 LETTERS,
                 "1", "2", "3", "4", "5", "6", "7", "8", "9", "0",
                 "!", "@", "#", "$", "%", "^", "&", "*", "(", ")",
                 "_", "-", "+", "=", "{", "[", "}", "]", "|", ":",
                 ";", "<", ",", ">", ".", "?", "/")
  p <- ""
  while(check_password_strength(p)$score < min_password_score){
    p <- paste(sample(possibles, length, replace = T), collapse = "")
  }
  return(p)
}

#' Function: compute_validation hash
#'
#' Compute a validation hash based on passwd (uncrypted), redcap key (uncrypted)
#' active boolean and role
#'
#' @param key redcap key uncrypted
#' @param active as numeric
#' @param role
#'
#' @return sha512 of the concatenation of the parameters
compute_validation_hash <- function(key, active, role){
  return(digest::digest(paste0(key, active, role), algo = "sha512"))
}

#' Function: create_user_df
#'
#' Create a dataframe for the use to be saved in the database. The sha512 is
#' saved for the passwords and the key is encrypted
#'
#' @param username the username
#' @param passwd the password
#' @param key the redcap key to encrypt and save
#'
#' @return a dataframe corresponding to the user info to save in the database
#'
#' Do no export
create_user_df <- function(username, passwd, key, active = 0, role = "basic"){
  passwd_digest <- digest::digest(passwd, algo = "sha512")
  timestamp <- as.POSIXct(Sys.time(),format = '%y-%m-%d %H:%M:%S NZDT')
  # To read the timestamp `as.POSIXct(1576108908, origin = "1970-01-01")`
  encrypted_key <- encrypt_redcap_key(passwd, key)
  # Make a list to save as one object in the database. Do not forget to unlist
  # when rettrieving the information
  encrypted_key <- list(encrypted_key)
  validation_hash <- compute_validation_hash(key, active, role)
  return(data.frame(username = username,
                    passwd_hash = passwd_digest,
                    key = I(encrypted_key),
                    created_at = timestamp,
                    active = active,
                    role = role,
                    validation_hash = validation_hash
                    ))
}


#' Function: get_all_users
#'
#' Returns a data frame with all the user info
#'
#' @param database the path to the database to use (sqlite)
#'
#' @return a data frame with all the user informations
#'
#' @export
get_all_users <- function(database) {
  con <- DBI::dbConnect(RSQLite::SQLite(), database)
  tables <- DBI::dbListTables(con)
  if(! "users" %in% tables){
    # Create a fake account that won't be saved in the database to ensure that
    # the right type of data is used
    logger::log_debug("INIT DB")
    passwd <- "init"
    key <- "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA"
    username <- "init"
    users <- create_user_df(username, passwd, key)
    users <- users[users$username != "init", ]
    DBI::dbWriteTable(con, "users", users)
  }
  users <- DBI::dbReadTable(con, "users")
  DBI::dbDisconnect(con)
  return(users)
}

#' Function: create_user
#'
#' create a user based on username, password, redcap_key in the database. Fails
#' if the username already present and returns the existing user with that
#' username
#'
#' @param username the username
#' @param password the password
#' @param redcap_key the redcap key to encrypt and save
#' @param database the path to the database to use (sqlite)
#'
#' @return a dataframe of the saved information (read from the database)
#'
#' @export
create_user <- function(username, password, redcap_key, database) {
  users <- get_all_users(database)
  con <- DBI::dbConnect(RSQLite::SQLite(), database)
  if(username %in% users$username){
    logger::log_error(paste0("User ", username, " already exist in the database"))
    return(get_user(username, database))
  }
  if(check_password_strength(password)$score < min_password_score){
    logger::log_error("Password too simple, not updated")
    return(NULL)
  }
  if(nrow(users) == 0 || is.null(users)){
    new_user <- create_user_df(username, password, redcap_key, role = "admin")
  }else{
    new_user <- create_user_df(username, password, redcap_key)
  }
  DBI::dbWriteTable(con, "users", new_user, overwrite = F, append = T)
  DBI::dbDisconnect(con)
  return(get_user(username, database))
}

#' Function: get_user
#'
#' Get a user information from its username (or NULL if doesn't exist)
#'
#' @param username the username
#' @param database the path to the database to use (sqlite)
#'
#' @return a dataframe with the user info or NULL if the username doesn't exist
#'
#' @export
get_user <- function(username, database){
  users <- get_all_users(database)
  if(!username %in% users$username){return(NULL)}
  user <- users[users$username == username, ][1,]
  return(as.list(user))
}

#' Function: get_user_key
#'
#' Returns the encrypted redcap_key of a user using its username
#'
#' @param username the username
#' @param database the path to the database to use (sqlite)
#'
#' @return the encrypted key as a raw type of object
#'
#' @export
get_user_key <- function(username, database){
  user <- get_user(username, database)
  if(is.null(user)){return(NULL)}
  return(unlist(user[["key"]]))
}

#' Function: validate_user
#'
#' Validates a user comparing its data to the validation hash
#'
#' @param username the username
#' @param password the password
#' @param database the path to the database to use (sqlite)
#'
#' @return TRUE if valid, else FALSE
#'
#' @export
validate_user <- function(username, password, database){
  if(!check_password(username, database, password)){return(FALSE)}
  user <- get_user(username, database)
  key <- get_user_key(username, database)
  key <- decrypt_redcap_key(password, key)
  ts <- user[["created_at"]]
  active <- user[["active"]]
  role <- user[["role"]]
  validation_hash <- compute_validation_hash(key, active, role)
  return(validation_hash == user$validation_hash[1])
}

#' Function: check_password
#'
#' Check that the password correspond to the passwd_hash field in the database
#'
#' @param username username
#' @param database database
#' @param password
#'
#' @return TRUE if the password correspond to its hash, FALSE else
#'
#' @export
check_password <- function(username, database, password){
  user <- get_user(username, database)
  if(is.null(user)){return(FALSE)}
  return(digest::digest(password, algo = "sha512") == user[["passwd_hash"]])
}

#' Function: Update user
#'
#' Given a username, password and database, the corresponding user is updated
#' with extra information provided as function arguments:
#'
#' \itemize{
#'  \item{"key"}{the redcap key}
#'  \item{"active"}{is user active}
#'  \item{"role"}{what is user role}
#' }
#'
#' The following fields can't be updated for security purposes:
#'
#' \itemize{
#'  \item{username}{}
#'  \item{passwd_hash}{}
#'  \item{validation_hash}{}
#'  \item{password}{}
#'  \item{key}{}
#'  \item{created_at}{}
#'  \item{role}{}
#'  \item{active}{}
#' }
#'
#' @param username the username
#' @param database the database
#' @param current_password the password
#'
#' @return the update user or NULL if it fails
#'
#' @export
update_user <- function(username, database, current_password, ...){
  if(!check_password(username, database, current_password)){
    logger::log_debug("Password not checked")
    return(NULL)
  }
  params <- c(as.list(environment()), list(...))
  user <- get_user(username, database)
  current_key <- get_user_key(username, database)
  current_key <- decrypt_redcap_key(current_password, current_key)
  new_user <- as.list(create_user_df(username, current_password, database))
  forbiden_fields <- c(
    "username",
    "passwd_hash",
    "validation_hash",
    "password",
    "key",
    "created_at",
    "role",
    "active"
  )

  # for(x in names(params)){
  #   if(x %in% forbiden_fields){next}
  #   if(x %in% names(user)){
  #     new_user[[x]] <- params[[x]]
  #   }
  # }
  if("password" %in% names(params)){
    password <- params[["password"]]
    if(check_password_strength(password)$score < min_password_score){
      logger::log_error("Password too simple, not updated")
      return(NULL)
    }

  } else{
    password <- current_password
  }
  if("key" %in% names(params)){
    key <- params[["key"]]
  }else{
    key <- current_key
  }
  new_user <- create_user_df(username = username,
                             passwd = password,
                             key = key,
                             active = new_user[["active"]],
                             role = new_user[["role"]])
  users <- get_all_users(database)
  users <- users[users$username != username, ]
  con <- DBI::dbConnect(RSQLite::SQLite(), database)
  DBI::dbWriteTable(con, "users", users, overwrite = T, append = F)
  DBI::dbWriteTable(con, "users", new_user, overwrite = F, append = T)
  DBI::dbDisconnect(con)
  return(get_user(username, database))
}

#' Function: update_user_with_admin_access
#'
#' Given a username, password and database, the corresponding user is updated
#' with extra information provided as function arguments:
#'
#' \itemize{
#'  \item{"key"}{the redcap key}
#'  \item{"active"}{is user active}
#'  \item{"role"}{what is user role}
#' }
#'
#' Only the following fields can be updated for security purposes:
#'
#' \itemize{
#'  \item{role}{}
#' }
#'
#' @param admin_username the admin username
#' @param admin_password the admin password
#' @param username the user to modify username
#' @param password the user to modify password
#' @param database the database
#'
#' @return the update user or NULL if it fails
#'
#' @export
update_user_with_admin_access <- function(admin_username,
                                          admin_password,
                                          username,
                                          password,
                                          database,
                                          ...){
  if(!validate_user(admin_username, admin_password, database) ||
     get_user(admin_username, database)$role != "admin"){
    logger::log_debug("Admin password not checked")
    return(NULL)
  }
  if(!validate_user(username, password, database)){
    logger::log_debug("Admin password not checked")
    return(NULL)
  }
  params <- c(as.list(environment()), list(...))
  user <- get_user(username, database)
  current_key <- get_user_key(username, database)
  current_key <- decrypt_redcap_key(password, current_key)
  new_user <- as.list(create_user_df(username, password, database))

  allowed_fields <- c(
    "role",
    "active"
  )

  for(x in names(params)){
    if(!x %in% allowed_fields){next}
    if(x %in% names(user)){
      new_user[[x]] <- params[[x]]
    }
  }

  new_user <- create_user_df(username = username,
                             passwd = password,
                             key = current_key,
                             active = new_user[["active"]],
                             role = new_user[["role"]])
  users <- get_all_users(database)
  users <- users[users$username != username, ]
  con <- DBI::dbConnect(RSQLite::SQLite(), database)
  DBI::dbWriteTable(con, "users", users, overwrite = T, append = F)
  DBI::dbWriteTable(con, "users", new_user, overwrite = F, append = T)
  DBI::dbDisconnect(con)
  return(get_user(username, database))
}

#' Function: delete_user
#'
#' Deletes a user given a username and password
#'
#' @param username usernmae
#' @param password password
#' @param database database
#'
#' @return TRUE if user is deleted, FALSE else
#'
#' @export
delete_user <- function(admin_username, admin_password, username, database){
  if(!validate_user(admin_username, admin_password, database) ||
     get_user(admin_username, database)$role != "admin"){
    logger::log_debug("Password not checked")
    return(FALSE)
  }
  users <- get_all_users(database)
  users <- users[users$username != username, ]
  con <- DBI::dbConnect(RSQLite::SQLite(), database)
  DBI::dbWriteTable(con, "users", users, overwrite = T, append = F)
  DBI::dbDisconnect(con)
  return(is.null(get_user(username, database)))
}

#' Computes a pasword strength. Based on the zxcvbn algorithm of dropbox
#'
#' @param password the password to test
#'
#' @return a list with `score` (0-4) and `feedback` slots
#'
#' @export
check_password_strength <- function(password){
  zxcvbn <- "zxcvbn.js"
  if(!file.exists(zxcvbn)){
    zxcvbn_url <- "https://raw.githubusercontent.com/dropbox/zxcvbn/master/dist/zxcvbn.js"
    # tmp <- tempfile("zxcvbn.js")
    download.file(url = zxcvbn_url, destfile = zxcvbn)
    # zxcvbn <- tmp
  }
  ct <- V8::v8()
  ct$source(zxcvbn)
  X <- ct$get(paste0("zxcvbn('",password,"')"))
  X$score
  # X$feedback
  return(list(score = X$score, feedback=X$feedback))
}