R/checkSystem.R

In acidgenomics/r-koopa: Shell Bootloader for Bioinformatics

#' Check system
#'
#' @export
#' @note Updated 2023-10-16.
#'
#' @return Invisible `TRUE` on success. Error on failure.
#'
#' @examples
#' ## > checkSystem()
checkSystem <- function() {
    assert(requireNamespaces(c("pipette", "syntactic")))
    .checkAppVersions()
    .checkAppLinks()
    if (!.isBuilder()) {
        .checkSysApps()
        .checkSysVersions()
    }
    if (Sys.getenv("KOOPA_CHECK_FAIL") == 1L) {
        abort("System failed checks.", call = FALSE)
    }
    invisible(TRUE)
}



#' Check app links
#'
#' @note Updated 2023-10-17.
#' @noRd
.checkAppLinks <- function() {
    json <- .importAppJson()
    sysDict <- .sysDict()
    x <- Map(
        name = names(json),
        json = json,
        MoreArgs = list("sysDict" = sysDict),
        f = function(name, json, sysDict) {
            ok <- .isAppSupported(
                name = name,
                json = json,
                sysDict = sysDict
            )
            if (isFALSE(ok)) {
                return(NULL)
            }
            out <- character()
            if (!is.null(json[["bin"]])) {
                bin <- unlist(
                    x = json[["bin"]],
                    recursive = FALSE,
                    use.names = FALSE
                )
                bin <- file.path(sysDict[["prefix"]], "bin", bin)
                out <- append(x = out, values = bin)
            }
            if (!is.null(json[["man1"]])) {
                man1 <- unlist(
                    x = json[["man1"]],
                    recursive = FALSE,
                    use.names = FALSE
                )
                man1 <- file.path(
                    sysDict[["prefix"]], "share", "man", "man1", man1
                )
                out <- append(x = out, values = man1)
            }
            out
        }
    )
    x <- Filter(f = Negate(is.null), x = x)
    x <- unlist(x, recursive = FALSE, use.names = FALSE)
    x <- sort(x)
    .checkInstalled(x)
}



#' Check app version
#'
#' @note Updated 2023-03-27.
#' @noRd
#'
#' @param name `character`.
#' Program name.
#' Parameterized, supporting multiple checks in a single call.
#'
#' @param current,expected `numeric_version`.
#' Current or expected version number.
#'
#' @return Invisible `logical`.
#'
#' @examples
#' .checkAppVersion(c("tmux", "vim"))
.checkAppVersion <-
    function(name,
             current = .currentVersion(name),
             expected = .expectedVersion(name)) {
        assert(
            isCharacter(name),
            identical(length(name), length(current)),
            identical(length(name), length(expected))
        )
        statusList <- .status()
        invisible(Map(
            name = name,
            current = current,
            expected = expected,
            f = function(name, current, expected) {
                if (is.na(current)) {
                    .setCheckFail()
                    message(sprintf(
                        fmt = "  %s | %s",
                        statusList[["fail"]], name
                    ))
                    return(FALSE)
                }
                ok <- current == expected
                if (isFALSE(ok)) {
                    .setCheckFail()
                    message(sprintf(
                        fmt = "  %s | %s (%s %s %s)",
                        statusList[["fail"]], name, current, "!=", expected
                    ))
                }
                ok
            }
        ))
    }



#' Check all koopa application versions
#'
#' @note Updated 2023-10-17.
#' @noRd
.checkAppVersions <- function() {
    apps <- c(sharedApps(), installedSharedApps())
    apps <- sort(unique(apps))
    .checkAppVersion(apps)
}



#' Check if a file or program exists
#'
#' @note Updated 2023-10-17.
#' @noRd
#'
#' @param x `character`.
#' Application file path.
#'
#' @return `logical`.
#'
#' @examples
#' x <- file.path("", "bin", c("XXX", "bash"))
#' .checkInstalled(x)
.checkInstalled <-
    function(x) {
        assert(isCharacter(x))
        statusList <- .status()
        invisible(vapply(
            X = x,
            FUN = function(x) {
                ok <- file.exists(x)
                if (isFALSE(ok)) {
                    .setCheckFail()
                    message(sprintf("  %s | %s", statusList[["fail"]], x))
                }
                ok
            },
            FUN.VALUE = logical(1L)
        ))
    }



#' Check that system applications are installed
#'
#' @note Updated 2023-06-27.
#' @noRd
.checkSysApps <- function() {
    platform <- .platform()
    x <- c(
        file.path("", "bin", "ps"),
        file.path("", "bin", "sh"),
        file.path("", "usr", "bin", "g++"),
        file.path("", "usr", "bin", "gcc")
    )
    x <- append(
        x = x,
        values = switch(
            EXPR = platform,
            "linux" = c(
                file.path("", "usr", "bin", "docker"),
                file.path("", "usr", "bin", "tlmgr")
            ),
            "macos" = c(
                file.path("", "Library", "TeX", "texbin", "tlmgr"),
                file.path("", "usr", "bin", "clang"),
                file.path("", "usr", "local", "include", "omp-tools.h"),
                file.path("", "usr", "local", "include", "omp.h"),
                file.path("", "usr", "local", "include", "ompt.h"),
                file.path("", "usr", "local", "lib", "libomp.dylib"),
                file.path(
                    "", "usr", "local", "texlive", "2023basic", "texmf-dist",
                    "tex", "latex", "inconsolata", "inconsolata.sty"
                )
            )
        )
    )
    .checkInstalled(sort(x))
}



#' Check application version
#'
#' @note Updated 2022-09-06.
#' @noRd
.checkSysVersion <- function(x) {
    statusList <- .status()
    invisible(vapply(
        X = x,
        FUN = function(x) {
            ok <- file.exists(x)
            if (isFALSE(ok)) {
                status <- statusList[["fail"]]
                msg <- sprintf("  %s | %s", status, x)
                message(msg)
            }
            current <- .currentSysVersion(x)
            expected <- .expectedVersion(x)
            ok <- identical(current, expected)
            if (isFALSE(ok)) {
                status <- statusList[["fail"]]
                msg <- sprintf(
                    "  %s | %s (%s != %s)",
                    status, x, current, expected
                )
                message(msg)
            }
            ok
        },
        FUN.VALUE = logical(1L)
    ))
}



#' Check system application versions
#'
#' @note Updated 2022-09-06.
#' @noRd
.checkSysVersions <- function() {
    platform <- .platform()
    x <- switch(
        EXPR = platform,
        "linux" = c(
            file.path("", "bin", "shiny-server"),
            file.path("", "sbin", "rstudio-server")
        ),
        "macos" = c(
            file.path(
                "",
                "Library",
                "Frameworks",
                "Python.framework",
                "Versions",
                "Current",
                "bin",
                "python3"
            ),
            file.path(
                "",
                "Library",
                "Frameworks",
                "R.framework",
                "Versions",
                "Current",
                "Resources",
                "bin",
                "R"
            )
        )
    )
    .checkSysVersion(sort(x))
}



#' Current system version of an application
#'
#' @note Updated 2022-09-06.
#' @noRd
#'
#' @details
#' Recommended to pass full executable file path here.
#'
#' @return `character`.
#' Returns `NA_character_` on match failure.
#'
#' @examples
#' binPrefix <- file.path(koopaPrefix(), "bin")
#' x <- file.path(binPrefix, c("R", "python3"))
#' .currentSysVersion(x)
.currentSysVersion <- function(x) {
    vapply(
        X = x,
        koopa = koopa(),
        FUN = function(x, koopa) {
            tryCatch(
                expr = {
                    x <- shell(
                        command = koopa,
                        args = c("system", "version", x),
                        print = FALSE
                    )
                    x <- x[["stdout"]]
                    x <- sub(pattern = "\n$", replacement = "", x = x)
                    x
                },
                warning = function(w) {
                    NA_character_
                },
                error = function(e) {
                    NA_character_
                }
            )
        },
        FUN.VALUE = character(1L),
        USE.NAMES = TRUE
    )
}



#' Current application version linked in opt
#'
#' @note Updated 2022-08-26.
#' @noRd
#'
#' @return `character`.
#' Returns `NA_character_` on match failure.
#'
#' @examples
#' .currentVersion(c("python", "r"))
.currentVersion <-
    function(name) {
        optPrefix <- koopaOptPrefix()
        vapply(
            X = name,
            optPrefix = optPrefix,
            FUN = function(name, optPrefix) {
                dir <- file.path(optPrefix, name)
                if (!dir.exists(dir)) {
                    return(NA_character_)
                }
                dir <- realpath(dir)
                out <- basename(dir)
                out
            },
            FUN.VALUE = character(1L),
            USE.NAMES = TRUE
        )
    }



#' Expected version of an application
#'
#' @note Updated 2023-10-03.
#' @noRd
#'
#' @return `character`.
#' Returns `NA_character_` on match failure.
#'
#' @examples
#' .expectedVersion(c("python", "r"))
.expectedVersion <- function(x) {
    json <- .importAppJson()
    vapply(
        X = x,
        FUN = function(x, json) {
            name <- tolower(basename(x))
            switch(
                EXPR = name,
                "python3" = {
                    py <- grep(
                        pattern = "^python",
                        x = names(json),
                        value = TRUE
                    )
                    name <- py[[length(py)]]
                }
            )
            version <- json[[name]][["version"]]
            if (!isString(version)) {
                abort(sprintf("Not supported: {.var %s}.", x), call = FALSE)
            }
            ## Convert full git commit to short 7 character string.
            if (identical(nchar(version), 40L)) {
                version <- substr(version, start = 1L, stop = 7L)
            }
            version
        },
        FUN.VALUE = character(1L),
        json = json,
        USE.NAMES = TRUE
    )
}



#' Check failure
#'
#' Set a system environment variable that we can detect in `koopa check`.
#'
#' @note Updated 2020-08-11.
#' @noRd
.setCheckFail <- function() {
    Sys.setenv("KOOPA_CHECK_FAIL" = 1L) # nolint
}



#' Status labels
#'
#' @note Updated 2022-08-26.
#' @noRd
#'
#' @return `list`.
.status <- function() {
    list(
        "fail" = red("FAIL"),
        "note" = yellow("NOTE"),
        "ok"   = green("  OK")
    )
}