aseshms: Toolkit for ASES HMS Team

#' Input password key
#'
#' Input a password phrase. It returns nothing unless you assign the output to a
#' variable.
#'
#' @author Yiying Wang, \email{wangy@@aetna.com}
#' @param prompt character, the prompt label of the GUI window.
#' @param caption character, the caption of the GUI window.
#' @param encrypt logical, if the password will be encrypted (a raw vector). 
#' Default TRUE.
#' @param gui 'Rstudioapi', or 'Gwidgets', default 'Rstudioapi'. If 
#' 'Rstudioapi' and Rstudio version >= 1.1.419, then call \code{\link{askForPassword}}, 
#' else use a GUI wizard with gWidget2.
#' @param gen_pem logical, if generate a acckey.pem file to store the cypher key 
#' of the password in under Sys.getenv('HOME'). Default TRUE.
#' @param ... other arguments.
#' @return invisible
#' 
#' @importFrom rstudioapi isAvailable getVersion
#' @export
#'
#' @seealso \code{\link[rstudioapi]{askForPassword}}  \code{\link[rstudioapi]{askForSecret}}
#' You can also use \code{\link{getPwd}} directly
#' @examples
#' \dontrun{
#' inputPwd(prompt="Input the db key", caption="Password")
#' }
#' 
inputPwd <- function(prompt=NULL, caption=NULL, encrypt=TRUE, 
                     gui=c("Rstudioapi", "Gwidgets"), gen_pem=TRUE, ...) {
    guiClass <- structure(NA, class=match.arg(gui))
    if (! isAvailable() || getVersion() < '1.1.419')
        class(guiClass) <- "Gwidgets"
    pwd <- guiInputPwd(prompt=prompt, caption=caption, encrypt=encrypt, 
                       guiClass=guiClass, ...)
    if (is.null(pwd)) return(NULL)
    if ("encrypted" %in% class(pwd)) {
        pwd <- encryptIt(pwd)
        if (class(pwd)[1] != "encrypt") class(pwd) <- c("encrypt", class(pwd))
    }
    if (gen_pem) if (is.raw(pwd)) 
        suppressWarnings(writeRawToPem(pwd, force=FALSE))
    return(invisible(pwd))
}

guiInputPwd <- function(prompt, caption, encrypt, guiClass, ...) 
    UseMethod(".inputPwd", guiClass)

#' @export
#' @importFrom digest AES
#' @importFrom rstudioapi askForSecret
.inputPwd.Rstudioapi <- function(prompt=NULL, caption=NULL, encrypt=TRUE, ...){
    pwdVal <- askForSecret("Password", message=ifnull(
        prompt, "Input the password: \n(DO NOT DISCLOSE THE PASSWORD TO OTHERS!)"), 
        title=ifnull(caption, "Enter the key"))
    if (is.null(pwdVal)) return(NULL)
    class(pwdVal) <- if (encrypt) "encrypted" else "plain"
    
    return(pwdVal)
}

#' @export
#' @importFrom gWidgets2 gbasicdialog gframe glabel ggroup gedit focus visible
.inputPwd.Gwidgets <- function(prompt=NULL, caption=NULL, encrypt=TRUE, ...){
    ## Based on code by Barry Rowlingson
    ## http://r.789695.n4.nabble.com/tkentry-that-exits-after-RETURN-tt854721.html#none
    
    env0 <- environment()
    win <- gbasicdialog(ifnull(caption, "Enter the key"), handler=function(h, ...){
        pwdVal <- pwd$get_value()
        class(pwdVal) <- if (encrypt) "encrypted" else "plain"
        assign("pwdVal", pwdVal, envir=env0)
    }, toolkit=guiToolkit(getOption("guiToolkit")))
    size(win) <- c(100, 30)
    
    frame <- gframe(cont=win, horizontal=FALSE)
    box1 <- ggroup(horizontal=FALSE, cont=frame)
    msg <- glabel("DO NOT DISCLOSE THE PASSWORD TO OTHERS!", cont=box1)
    font(msg) <- list(family="helvetica", color="red")
    box2 <- ggroup(horizontal=FALSE, cont=frame)
    lbl <- glabel(ifnull(prompt, "Input the password:"), cont=box2)
    font(lbl) <- list(family="sans", scale="large")
    pwd <- gedit(cont=box2, width=25)
    visible(pwd) <- FALSE
    focus(pwd) <- TRUE
    visible(win, TRUE)
    return(env0$pwdVal)
}


#' @export
.inputPwd.default <- .inputPwd.Rstudioapi   

#' @export
print.encrypt <- print.encrypted <- function(x) 
    print.default(strrep("*", 16))


#' Get ACC password from the acckey.pem file
#' 
#' If the acckey.pem file already exists, it extracts the cipher text from it and
#' decrypt it into key string. Otherwise, it will call \code{inputPwd} to enter
#' the password. \cr
#' Note that this function returns \strong{an encrypted raw vector} which needs 
#' to be \code{\link{decrypt_it}}ed.
#' @author Yiying Wang, \email{wangy@@aetna.com}
#' @param overide logical, if overide existing acckey.pem and input password again.
#' Default FALSE.
#' @return invisible (a encrypted raw vector)
#' @export
#' 
#' @seealso \code{\link{inputPwd}}  \code{\link{decrypt_it}}
#' @examples
#' \dontrun{
#' func <- function() {
#'     con <- DBI::dbConnect(odbc::odbc(), .connection_string=paste0(
#'         "Driver={Microsfot Access Driver (*.mdb, *.accdb)};",
#'         "Dbq=testdb.accdb;uid=;pwd=", decrypt_it(getPwd())))
#'     return(DBI::dbGetQuery(con, "select * from table1"))
#' } 
#' }
#' 
getPwd <- function(overide=FALSE){
    pemfile <- paste0(Sys.getenv("HOME"), "/acckey.pem")
    if (!overide && file.exists(pemfile)){
        keystr <- readLines(pemfile)
        keystr <- paste(keystr[2:(length(keystr)-1)], collapse="")
        
        seq_from <- seq(1, nchar(keystr), 2)
        seq_to <- seq(2, nchar(keystr), 2)
        if (length(seq_to) < length(seq_from)) seq_to <- c(seq_to, nchar(keystr))
        
        keystr <- substring(keystr, seq_from, seq_to)
        keystr <- as.raw(as.hexmode(keystr))
    }else{
        keystr <- inputPwd(encrypt=TRUE)
    }
    if (is.raw(keystr)) if (class(keystr)[1] != "encrypt") 
        class(keystr) <- c("encrypt", class(keystr))
    
    return(invisible(keystr))
}

#' @export
#' @rdname getPwd
get_pwd <- getPwd

# ----------encrpyt and decrypt----------

builtinKey <- function(){
    key <- charToRaw(paste(
        Sys.info()[c('sysname', 'machine', 'effective_user')], collapse=" "))
    return(c(key, as.raw(rep(charToRaw(' '), 32 - length(key) %% 32))))
}

#' @importFrom digest AES
builtinAES <- function(IV.char=NULL){
    if (is.null(IV.char)){
        IV.char <- as.character(getOption("aseshms.loaded.at"))
    }
    IV.char <- paste0(substr(IV.char, 1, 8), 
                      if (nchar(IV.char) < 8) strrep(" ", 8 - nchar(IV.char)))
    
    return(AES(builtinKey(), mode="CBC", IV=charToRaw(IV.char)))
}

writeRawToPem <- function(x, force=FALSE, ...){
    pemfile <- paste0(Sys.getenv("HOME"), '/acckey.pem')
    if (file.exists(pemfile)){
        if (force) {
            unlink(pemfile) 
        }else{
            invisible(warning("Not updated: the acckey.pem already exists."))
            return(invisible())
        }
    }
    UseMethod(".writeRawToPem", x)
}

.writeRawToPem.raw <- function(x, force=FALSE, ...){
    pemfile <- paste0(Sys.getenv("HOME"), '/acckey.pem')
    x <- paste(x, collapse="")
    if (nchar(x) > 40) {
        seq_from <- seq(1, nchar(x), 40)
        seq_to <- seq(40, nchar(x), 40)
        if (length(seq_to) < length(seq_from)) seq_to <- c(seq_to, nchar(x))
        
        x <- substring(x, seq_from, seq_to)
    }
    cat(c("-----START PRIVATE KEY FOR ACC CONN-----", x[x != ""], 
          "-----END PRIVATE KEY FOR ACC CONN-----"), file=pemfile, sep="\n")
    invisible(message("acckey.pem generated."))
}

.writeRawToPem.encrypt <- .writeRawToPem.raw

.writeRawToPem.default <- function(x, force=FALSE, ...){
    x <- as.character(x)
    .writeRawToPem.raw(x, force=force, ...)
}


# ----encrypt a string----

encryptIt <- function(x, ...){
    UseMethod(".encryptIt", x)
}

encrypt_it <- encryptIt

#' @importFrom digest AES
.encryptIt.character <- function(x, ...){
    dots <- list(...)
    x <- paste(unlist(strsplit(x, "")), collapse="\uff0b")
    x <- charToRaw(paste0(aseshms_env$START_TAG, x, aseshms_env$END_TAG))
    x <- c(x, rep(charToRaw(' '), 32 - length(x) %% 32))
    IV.char <- if ("IV.char" %in% names(dots)) dots[['IV.char']] else NULL
    o <- builtinAES(IV.char)$encrypt(x)
    if (is.raw(o)) if (class(o)[1] != "encrypt") 
        class(o) <- c("encrypt", class(o))
    return(o)
}

.encryptIt.default <- function(x) {
    .encryptIt.character(as.character(x))
}

#' Decrypt a raw vector
#'
#' It calls a builtin algorithm to decrypt a raw vector. If it is not of the \code{encrypt}
#' class, the value will be returned as-is.
#' @param x The string to decrypt
#'
#' @return invisible
#' @export
#' @rdname encryptIt
#'
#' @examples
#' \dontrun{
#' decryptIt("Pwd")
#' }
decryptIt <- function(x, ...){
    UseMethod(".decryptIt", x)
}

#' @export
#' @rdname encryptIt
decrypt_it <- decryptIt

#' @export
.decryptIt.default <- function(x, ...) invisible(unclass(x))

#' @export
.decryptIt.encrypt <- function(x, ...){
    # key <- unlist(strsplit(x, ""))
    # key <- gsub("-", "01", gsub("\\.", "00", key))
    # key <- rawToChar(packBits(as.integer(key)))
    
    dots <- list(...)
    IV.char <- if ("IV.char" %in% names(dots)) dots[['IV.char']] else NULL
    o <- paste(builtinAES(IV.char)$decrypt(x, raw=TRUE), collapse=" ")
    
    start <- paste(charToRaw(aseshms_env$START_TAG), collapse=" ")
    end <- paste(charToRaw(aseshms_env$END_TAG), collapse=" ")
    joint <- paste(charToRaw("\uff0b"), collapse=" ")
    
    o <- unlist(strsplit(o, paste0(start, "|", end, "|", joint)))
    o <- trimws(o[2:(length(o)-1)])
    o <- rawToChar(as.raw(as.hexmode(o)))
    invisible(o)
}

#' @export
.decryptIt.plain <- .decryptIt.default