From d544e892287e30fb54cc22b007faeb78690712da Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 9 Sep 2022 09:46:42 +0200 Subject: [PATCH 01/79] prep and improve --- DESCRIPTION | 2 +- R/userAttribute.R | 101 +++++++++++++++++++++++----------------------- man/userInfo.Rd | 36 +++++++++-------- 3 files changed, 71 insertions(+), 68 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index f592fb0c..8d357b43 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -45,7 +45,7 @@ Imports: sship (>= 0.8.0), utils, yaml -RoxygenNote: 7.1.2 +RoxygenNote: 7.2.1 URL: https://github.com/Rapporteket/rapbase BugReports: https://github.com/Rapporteket/rapbase/issues Suggests: diff --git a/R/userAttribute.R b/R/userAttribute.R index 47c2e08f..3c3dbc9f 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -1,37 +1,39 @@ #' Provide user attributes based on environment context #' -#' Extracts elements from either config, url (shiny) or session (shiny) -#' relevant for user data such as name, group, role and reshId. Source of info -#' is based on environment context and can be controlled by altering the default -#' settings for which contexts that will apply for the various sources of user -#' data. This function will normally be used via its helper functions (see -#' below). +#' Extracts elements from either config, url (shiny), shiny session or +#' environmental variables relevant for user data such as name, group, role and +#' org id (\emph{e.g.} resh id). Source of info is based on environment context +#' and can be controlled by altering the default settings for which contexts +#' that will apply for the various sources of user data. This function will +#' normally be used via its helper functions (see below). #' #' @param entity String defining the element to return. Currently, one of -#' 'user', groups', 'resh_id', 'role', 'email', 'full_name' or 'phone' +#' 'user', groups', 'resh_id', 'role', 'email', 'full_name' or 'phone'. #' @param shinySession Shiny session object (list, NULL by default). Must be -#' provided when the source of user attributes is either the shiny app url or -#' an external authentication provider. By default this will apply to the -#' 'TEST', 'QA' and 'PRODUCTION' contexts in which case the shiny session -#' object must be provided. +#' provided when the source of user attributes is either the shiny app url or +#' an external authentication provider. By default this will apply to the +#' 'TEST', 'QA' and 'PRODUCTION' contexts in which case the shiny session +#' object must be provided. #' @param devContexts A character vector providing unique instances to be -#' regarded as a development context. In this context user attributes will be -#' read from configuration as provided by 'rapbaseConfig.yml'. The instances -#' provided cannot overlap instances provided in any other contexts. By default -#' set to \code{c("DEV")}. +#' regarded as a development context. In this context user attributes will be +#' read from configuration as provided by 'rapbaseConfig.yml'. The instances +#' provided cannot overlap instances provided in any other contexts. By +#' default set to \code{c("DEV")}. #' @param testContexts A character vector providing unique instances to be -#' regarded as a test context. In this context user attributes will be read -#' from the url call to a shiny application. Hence, for this context the -#' corresponding shiny session object must also be provided. The instances -#' provided cannot overlap instances provided in any other contexts. By default -#' set to \code{c("TEST")}. +#' regarded as a test context. In this context user attributes will be read +#' from the url call to a shiny application. Hence, for this context the +#' corresponding shiny session object must also be provided. The instances +#' provided cannot overlap instances provided in any other contexts. By +#' default set to \code{c("TEST")}. #' @param prodContexts A character vector providing unique instances to be -#' regarded as a production context. In this context user attributes will be -#' read from the shiny session object (as shiny server interacts with an -#' external log-in service). Hence, for this context the corresponding shiny -#' session object must also be provided. The instances provided cannot overlap -#' instances provided in any other contexts. By default set to -#' \code{c("QA", "PRODUCTION")}. +#' regarded as a production context. In this context user attributes will be +#' read from the shiny session object (on deployment in shiny-server) or, from +#' environmental variables (on standalone container deployment). Hence, for +#' this context the corresponding shiny session object must also be provided. +#' Instances provided cannot overlap instances in any other contexts. By +#' default set to \code{c("QA", "QAC", "PRODUCTION", "PRODUCTIONC")}. +#' Duplication as seen by the "C" suffix will be needed as long as apps in +#' question are to be run on both shiny-server and as standalone containers. #' #' @return String of single user data element #' @@ -40,9 +42,26 @@ #' #' @export -userInfo <- function(entity, shinySession = NULL, devContexts = c("DEV"), - testContexts = c("TEST"), - prodContexts = c("QA", "PRODUCTION")) { +userInfo <- function( + entity, + shinySession = NULL, + devContexts = c("DEV"), + testContexts = c("TEST"), + prodContexts = c("QA", "QAC", "PRODUCTION", "PRODUCTIONC") +) { + + # stop helper function + stopifnotShinySession <- function(object) { + if (!inherits( + shinySession, c("ShinySession", "session_proxy", "MockShinySession") + )) { + stop(paste( + "'ShinySession' argument is not a shiny session object! Cannot go on." + )) + } else { + invisible() + } + } # check for valid entities if (!(entity %in% c( @@ -50,7 +69,7 @@ userInfo <- function(entity, shinySession = NULL, devContexts = c("DEV"), "full_name", "phone" ))) { stop("Incorrect entity provided! Must be one of 'user', 'groups', 'resh_id' - 'role' or 'email'") + 'role', 'email', 'full_name' or 'phone'.") } # check if any contexts overlap, and stop if so @@ -76,17 +95,8 @@ userInfo <- function(entity, shinySession = NULL, devContexts = c("DEV"), } if (context %in% devContexts) { - if (is.null(shinySession)) { - stop("Session information is empty! Eventually, that will come bite you") - } - if (!any(c("ShinySession", "session_proxy", "MockShinySession") %in% - attributes(shinySession)$class)) { - stop(paste( - "Got no object of class 'ShinySession' or 'session_proxy'!", - "Your carma is way below threshold..." - )) - } + stopifnotShinySession(shinySession) conf <- getConfig(fileName = "rapbaseConfig.yml") d <- conf$r$testUser @@ -100,17 +110,8 @@ userInfo <- function(entity, shinySession = NULL, devContexts = c("DEV"), } if (context %in% testContexts || context %in% prodContexts) { - if (is.null(shinySession)) { - stop("Session information is empty!. Cannot do anything") - } - if (!any(c("ShinySession", "session_proxy") %in% - attributes(shinySession)$class)) { - stop(paste( - "Got no object of class 'ShinySession' or 'session_proxy'!", - "Cannot do anything" - )) - } + stopifnotShinySession(shinySession) if (context %in% testContexts) { us <- shiny::parseQueryString(shinySession$clientData$url_search) diff --git a/man/userInfo.Rd b/man/userInfo.Rd index 3796a352..387161be 100644 --- a/man/userInfo.Rd +++ b/man/userInfo.Rd @@ -9,12 +9,12 @@ userInfo( shinySession = NULL, devContexts = c("DEV"), testContexts = c("TEST"), - prodContexts = c("QA", "PRODUCTION") + prodContexts = c("QA", "QAC", "PRODUCTION", "PRODUCTIONC") ) } \arguments{ \item{entity}{String defining the element to return. Currently, one of -'user', groups', 'resh_id', 'role', 'email', 'full_name' or 'phone'} +'user', groups', 'resh_id', 'role', 'email', 'full_name' or 'phone'.} \item{shinySession}{Shiny session object (list, NULL by default). Must be provided when the source of user attributes is either the shiny app url or @@ -25,34 +25,36 @@ object must be provided.} \item{devContexts}{A character vector providing unique instances to be regarded as a development context. In this context user attributes will be read from configuration as provided by 'rapbaseConfig.yml'. The instances -provided cannot overlap instances provided in any other contexts. By default -set to \code{c("DEV")}.} +provided cannot overlap instances provided in any other contexts. By +default set to \code{c("DEV")}.} \item{testContexts}{A character vector providing unique instances to be regarded as a test context. In this context user attributes will be read from the url call to a shiny application. Hence, for this context the corresponding shiny session object must also be provided. The instances -provided cannot overlap instances provided in any other contexts. By default -set to \code{c("TEST")}.} +provided cannot overlap instances provided in any other contexts. By +default set to \code{c("TEST")}.} \item{prodContexts}{A character vector providing unique instances to be regarded as a production context. In this context user attributes will be -read from the shiny session object (as shiny server interacts with an -external log-in service). Hence, for this context the corresponding shiny -session object must also be provided. The instances provided cannot overlap -instances provided in any other contexts. By default set to -\code{c("QA", "PRODUCTION")}.} +read from the shiny session object (on deployment in shiny-server) or, from +environmental variables (on standalone container deployment). Hence, for +this context the corresponding shiny session object must also be provided. +Instances provided cannot overlap instances in any other contexts. By +default set to \code{c("QA", "QAC", "PRODUCTION", "PRODUCTIONC")}. +Duplication as seen by the "C" suffix will be needed as long as apps in +question are to be run on both shiny-server and as standalone containers.} } \value{ String of single user data element } \description{ -Extracts elements from either config, url (shiny) or session (shiny) -relevant for user data such as name, group, role and reshId. Source of info -is based on environment context and can be controlled by altering the default -settings for which contexts that will apply for the various sources of user -data. This function will normally be used via its helper functions (see -below). +Extracts elements from either config, url (shiny), shiny session or +environmental variables relevant for user data such as name, group, role and +org id (\emph{e.g.} resh id). Source of info is based on environment context +and can be controlled by altering the default settings for which contexts +that will apply for the various sources of user data. This function will +normally be used via its helper functions (see below). } \seealso{ \code{\link{getUserName}}, \code{\link{getUserGroups}}, From 4c5548607b909f16619616c133fab92b5406393a Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 9 Sep 2022 10:51:11 +0200 Subject: [PATCH 02/79] extending user attribs to container instance for QA and PROD contexts --- DESCRIPTION | 3 ++- R/userAttribute.R | 40 +++++++++++++++++++++++----------- man/userInfo.Rd | 2 +- tests/testthat/setup.R | 1 + tests/testthat/test-userInfo.R | 25 +++++++++++++++++++++ 5 files changed, 56 insertions(+), 15 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8d357b43..a3be7494 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -52,4 +52,5 @@ Suggests: httptest, lifecycle, rvest, - testthat + testthat, + withr diff --git a/R/userAttribute.R b/R/userAttribute.R index 3c3dbc9f..c08258de 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -38,7 +38,7 @@ #' @return String of single user data element #' #' @seealso \code{\link{getUserName}}, \code{\link{getUserGroups}}, -#' \code{\link{getUserReshId}}, \code{\link{getUserRole}} +#' \code{\link{getUserReshId}}, \code{\link{getUserRole}} #' #' @export @@ -109,22 +109,25 @@ userInfo <- function( phone <- d$phone } - if (context %in% testContexts || context %in% prodContexts) { + if (context %in% testContexts) { stopifnotShinySession(shinySession) - if (context %in% testContexts) { - us <- shiny::parseQueryString(shinySession$clientData$url_search) - user <- us$`X-USER` - groups <- us$`X-GROUPS` - resh_id <- us$resh_id - role <- us$role - email <- us$email - full_name <- us$full_name - phone <- us$phone - } + us <- shiny::parseQueryString(shinySession$clientData$url_search) + user <- us$`X-USER` + groups <- us$`X-GROUPS` + resh_id <- us$resh_id + role <- us$role + email <- us$email + full_name <- us$full_name + phone <- us$phone + } - if (context %in% prodContexts) { + if (context %in% prodContexts) { + + stopifnotShinySession(shinySession) + + if (context %in% c("QA", "PRODUCTION")) { user <- shinySession$user groups <- shinySession$groups resh_id <- shinySession$request$HTTP_RESHID @@ -134,6 +137,17 @@ userInfo <- function( parse(text = paste0("'", shinySession$request$HTTP_FULLNAME, "'"))[[1]] phone <- shinySession$request$HTTP_PHONE } + + if (context %in% c("QAC", "PRODUCTIONC")) { + user <- Sys.getenv("SHINYPROXY_USERNAME") + groups <- Sys.getenv("SHINYPROXY_USERGROUPS") + resh_id <- Sys.getenv("USERORGID") + role <- Sys.getenv("USERROLE") + email <- Sys.getenv("USEREMAIL") + full_name <- + parse(text = paste0("'", Sys.getenv("USERFULLNAME"), "'"))[[1]] + phone <- Sys.getenv("USERPHONE") + } } switch(entity, diff --git a/man/userInfo.Rd b/man/userInfo.Rd index 387161be..1bd50fba 100644 --- a/man/userInfo.Rd +++ b/man/userInfo.Rd @@ -58,5 +58,5 @@ normally be used via its helper functions (see below). } \seealso{ \code{\link{getUserName}}, \code{\link{getUserGroups}}, -\code{\link{getUserReshId}}, \code{\link{getUserRole}} + \code{\link{getUserReshId}}, \code{\link{getUserRole}} } diff --git a/tests/testthat/setup.R b/tests/testthat/setup.R index 07b642cb..3483fe9c 100644 --- a/tests/testthat/setup.R +++ b/tests/testthat/setup.R @@ -1 +1,2 @@ library(httptest) +library(withr) diff --git a/tests/testthat/test-userInfo.R b/tests/testthat/test-userInfo.R index a192d8ad..a473b607 100644 --- a/tests/testthat/test-userInfo.R +++ b/tests/testthat/test-userInfo.R @@ -128,6 +128,31 @@ test_that("Function can handle redefined contexts", { ), "999999") }) +# New: container instance for QA and PRODUCTION contexts +with_envvar( + new = c( + "R_RAP_INSTANCE" = "QAC", + "SHINYPROXY_USERNAME" = "userc", + "SHINYPROXY_USERGROUPS" = "groupsc", + "USERORGID" = "13579", + "USERROLE" = "rolec", + "USEREMAIL" = "userc@container.no", + "USERFULLNAME" = "User Container", + "USERPHONE" = "+4787654321" + ), + code = { + test_that("User attribs can be fetched in container instance (QA, PROD)", { + expect_equal(getUserName(shinySession), "userc") + expect_equal(getUserGroups(shinySession), "groupsc") + expect_equal(getUserReshId(shinySession), "13579") + expect_equal(getUserRole(shinySession), "rolec") + expect_equal(getUserEmail(shinySession), "userc@container.no") + expect_equal(getUserFullName(shinySession), "User Container") + expect_equal(getUserPhone(shinySession), "+4787654321") + }) + } +) + # Restore instance Sys.setenv(R_RAP_INSTANCE = currentInstance) Sys.setenv(R_RAP_CONFIG_PATH = currentConfigPath) From 0af409affe337bb7dc24ce96ecd91faa77444cb5 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 9 Sep 2022 10:52:35 +0200 Subject: [PATCH 03/79] now in development --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index a3be7494..ebae44a2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rapbase Type: Package Title: Base Functions and Resources for Rapporteket -Version: 1.23.0 +Version: 1.23.0.9000 Authors@R: c( person(given = "Are", family = "Edvardsen", From 0f544f40c62b16c17600f9325fd0f93e5dc007a3 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 15 Sep 2022 14:28:21 +0200 Subject: [PATCH 04/79] new container contex missing --- R/autoReport.R | 2 +- R/misc.R | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/R/autoReport.R b/R/autoReport.R index 6b95a436..768570cc 100644 --- a/R/autoReport.R +++ b/R/autoReport.R @@ -55,7 +55,7 @@ createAutoReport <- function(synopsis, package, type = "subscription", fun, if (is.null(terminateDate)) { context <- Sys.getenv("R_RAP_INSTANCE") terminateDate <- as.POSIXlt(Sys.Date()) - if (context %in% c("PRODUCTION")) { + if (context %in% c("PRODUCTION", "PRODUCTIONC")) { terminateDate$year <- terminateDate$year + 3 } else { terminateDate$mon <- terminateDate$mon + 1 diff --git a/R/misc.R b/R/misc.R index 21f1e0e0..b6bbd16a 100644 --- a/R/misc.R +++ b/R/misc.R @@ -61,7 +61,8 @@ getRapPackages <- function() { #' isRapContext() #' isRapContext <- function() { - if (Sys.getenv("R_RAP_INSTANCE") %in% c("DEV", "TEST", "QA", "PRODUCTION")) { + if (Sys.getenv("R_RAP_INSTANCE") %in% + c("DEV", "TEST", "QA", "PRODUCTION", "PRODUCTIONC")) { return(TRUE) } else { return(FALSE) From 5b53c3db1a418a98b186c59e11b5208b435139c7 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 15 Sep 2022 15:27:46 +0200 Subject: [PATCH 05/79] update site docs --- _pkgdown.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index adc1f5fc..4613ffd6 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -50,6 +50,7 @@ reference: Handle logging contents: - logger + - sanitizeLog - title: Automated reports desc: > From 62a9b940243358facc11aeae437e1b83c3d6835a Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 16 Sep 2022 14:27:38 +0200 Subject: [PATCH 06/79] as container, apply internal default user group --- R/userAttribute.R | 2 +- tests/testthat/test-userInfo.R | 3 ++- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/R/userAttribute.R b/R/userAttribute.R index c08258de..01a8a914 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -140,7 +140,7 @@ userInfo <- function( if (context %in% c("QAC", "PRODUCTIONC")) { user <- Sys.getenv("SHINYPROXY_USERNAME") - groups <- Sys.getenv("SHINYPROXY_USERGROUPS") + groups <- shinySession$userData$defaultGroup resh_id <- Sys.getenv("USERORGID") role <- Sys.getenv("USERROLE") email <- Sys.getenv("USEREMAIL") diff --git a/tests/testthat/test-userInfo.R b/tests/testthat/test-userInfo.R index a473b607..3b9c1a6b 100644 --- a/tests/testthat/test-userInfo.R +++ b/tests/testthat/test-userInfo.R @@ -129,6 +129,7 @@ test_that("Function can handle redefined contexts", { }) # New: container instance for QA and PRODUCTION contexts +shinySession$userData$defaultGroup <- "myDefaultGroup" with_envvar( new = c( "R_RAP_INSTANCE" = "QAC", @@ -143,7 +144,7 @@ with_envvar( code = { test_that("User attribs can be fetched in container instance (QA, PROD)", { expect_equal(getUserName(shinySession), "userc") - expect_equal(getUserGroups(shinySession), "groupsc") + expect_equal(getUserGroups(shinySession), "myDefaultGroup") expect_equal(getUserReshId(shinySession), "13579") expect_equal(getUserRole(shinySession), "rolec") expect_equal(getUserEmail(shinySession), "userc@container.no") From 12d96f8f58227aedb6ff3dc4a9050196097f2373 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 20 Sep 2022 11:07:50 +0200 Subject: [PATCH 07/79] fix caller default value --- R/moduleNavbarWidget.R | 10 +++++++--- man/navbarWidget.Rd | 8 ++++++-- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index 85505b1b..1607f2af 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -12,7 +12,7 @@ #' @param addUserInfo Logical defining if an "about" hyperlink is to be added #' @param orgName Character string naming the organization #' @param caller Character string naming the environment this function was -#' called from. Default value is \code{environmentName(rlang::caller_env())}. +#' called from. Default value is \code{environmentName(topenv(parent.frame()))}. #' The value is used to display the current version of the R package #' representing the registry at Rapporteket. If this module is called from #' exported functions in the registry R package use the default value. If the @@ -68,8 +68,12 @@ navbarWidgetInput <- function(id, addUserInfo = TRUE) { #' @rdname navbarWidget #' @export -navbarWidgetServer <- function(id, orgName, - caller = environmentName(rlang::caller_env())) { +navbarWidgetServer <- function( + id, + orgName, + caller = environmentName(topenv(parent.frame())) +) { + shiny::moduleServer(id, function(input, output, session) { output$name <- shiny::renderText(rapbase::getUserFullName(session)) output$affiliation <- shiny::renderText( diff --git a/man/navbarWidget.Rd b/man/navbarWidget.Rd index d497a763..7e8b1147 100644 --- a/man/navbarWidget.Rd +++ b/man/navbarWidget.Rd @@ -9,7 +9,11 @@ \usage{ navbarWidgetInput(id, addUserInfo = TRUE) -navbarWidgetServer(id, orgName, caller = environmentName(rlang::caller_env())) +navbarWidgetServer( + id, + orgName, + caller = environmentName(topenv(parent.frame())) +) navbarWidgetApp(orgName = "Org Name") } @@ -21,7 +25,7 @@ navbarWidgetApp(orgName = "Org Name") \item{orgName}{Character string naming the organization} \item{caller}{Character string naming the environment this function was -called from. Default value is \code{environmentName(rlang::caller_env())}. +called from. Default value is \code{environmentName(topenv(parent.frame()))}. The value is used to display the current version of the R package representing the registry at Rapporteket. If this module is called from exported functions in the registry R package use the default value. If the From 91a2e949d0ed5d58bf2410f43a02bbdc65091f75 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 20 Sep 2022 11:20:31 +0200 Subject: [PATCH 08/79] fix message logic flaw --- R/stagingData.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 38bbff1d..2f11c55e 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -148,8 +148,8 @@ cleanStagingData <- function(eolAge, dryRun = TRUE) { paste( "Function invoked in dry run mode and none of the returned files\n", "will be deleted.\n", - "To delete the files please re-run this function with the dryRun\n", - "argument set to 'TRUE'. Godspeed!" + "To delete the files please contemplate and re-run this function\n", + "with the dryRun argument set to 'FALSE'. Godspeed!" ) ) fDelete From 02a41c38c9d19d38488dc0546a4d22db27a6518e Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 23 Sep 2022 15:16:46 +0200 Subject: [PATCH 09/79] prep for use of access tree --- data-raw/accesstree.R | 109 +++++++++++++++++++++++++++++++++++ inst/extdata/accesstree.json | 1 + 2 files changed, 110 insertions(+) create mode 100644 data-raw/accesstree.R create mode 100644 inst/extdata/accesstree.json diff --git a/data-raw/accesstree.R b/data-raw/accesstree.R new file mode 100644 index 00000000..8059564d --- /dev/null +++ b/data-raw/accesstree.R @@ -0,0 +1,109 @@ +j <- ' +{ + "AccessUnits": [ + { + "UnitId": 100082, + "ParentUnitId": 0, + "HasDatabase": true, + "ExternalId": 100082, + "HealthUnitId": null, + "Title": "Helse Bergen HF", + "TitleWithPath": "Helse Bergen HF", + "ValidFrom": null, + "ValidTo": null, + "ExtraData": null + }, + { + "UnitId": 102966, + "ParentUnitId": 100082, + "HasDatabase": true, + "ExternalId": 102966, + "HealthUnitId": null, + "Title": "HB Hjerteavdelingen", + "TitleWithPath": "Helse Bergen HF - HB Hjerteavdelingen", + "ValidFrom": null, + "ValidTo": null, + "ExtraData": null + }, + { + "UnitId": 4001031, + "ParentUnitId": 0, + "HasDatabase": true, + "ExternalId": 4001031, + "HealthUnitId": null, + "Title": "Oslo universitetssykehus HF", + "TitleWithPath": "Oslo universitetssykehus HF", + "ValidFrom": null, + "ValidTo": null, + "ExtraData": null + }, + { + "UnitId": 700328, + "ParentUnitId": 4001031, + "HasDatabase": true, + "ExternalId": 700328, + "HealthUnitId": null, + "Title": "Hjerte-, lunge- og karklinikken", + "TitleWithPath": "Oslo universitetssykehus HF - Hjerte-, lunge- og karklinikken", + "ValidFrom": null, + "ValidTo": null, + "ExtraData": null + }, + { + "UnitId": 100320, + "ParentUnitId": 0, + "HasDatabase": true, + "ExternalId": 100320, + "HealthUnitId": null, + "Title": "St. Olavs Hospital HF", + "TitleWithPath": "St. Olavs Hospital HF", + "ValidFrom": null, + "ValidTo": null, + "ExtraData": null + }, + { + "UnitId": 104284, + "ParentUnitId": 100320, + "HasDatabase": true, + "ExternalId": 104284, + "HealthUnitId": null, + "Title": "Klinikk for Hjertemedisin", + "TitleWithPath": "St. Olavs Hospital HF - Klinikk for Hjertemedisin", + "ValidFrom": null, + "ValidTo": null, + "ExtraData": null + }, + { + "UnitId": 106944, + "ParentUnitId": 0, + "HasDatabase": true, + "ExternalId": 106944, + "HealthUnitId": null, + "Title": "AHUS Gardermoen", + "TitleWithPath": "AHUS Gardermoen", + "ValidFrom": null, + "ValidTo": null, + "ExtraData": null + }, + { + "UnitId": 4214492, + "ParentUnitId": 106944, + "HasDatabase": true, + "ExternalId": 4214492, + "HealthUnitId": null, + "Title": "Hjertemedisinsk avdeling", + "TitleWithPath": "AHUS Gardermoen - Hjertemedisinsk avdeling", + "ValidFrom": null, + "ValidTo": null, + "ExtraData": null + } + ] + } +' + +accesstree <- jsonlite::parse_json(j) + +# Store it as an external data set in this package, please adjust path +# accordingly + +# jsonlite::write_json(accesstree, "./inst/extdata/accesstree.json") diff --git a/inst/extdata/accesstree.json b/inst/extdata/accesstree.json new file mode 100644 index 00000000..6e41e341 --- /dev/null +++ b/inst/extdata/accesstree.json @@ -0,0 +1 @@ +{"AccessUnits":[{"UnitId":[100082],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[100082],"HealthUnitId":{},"Title":["Helse Bergen HF"],"TitleWithPath":["Helse Bergen HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[102966],"ParentUnitId":[100082],"HasDatabase":[true],"ExternalId":[102966],"HealthUnitId":{},"Title":["HB Hjerteavdelingen"],"TitleWithPath":["Helse Bergen HF - HB Hjerteavdelingen"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[4001031],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[4001031],"HealthUnitId":{},"Title":["Oslo universitetssykehus HF"],"TitleWithPath":["Oslo universitetssykehus HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[700328],"ParentUnitId":[4001031],"HasDatabase":[true],"ExternalId":[700328],"HealthUnitId":{},"Title":["Hjerte-, lunge- og karklinikken"],"TitleWithPath":["Oslo universitetssykehus HF - Hjerte-, lunge- og karklinikken"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[100320],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[100320],"HealthUnitId":{},"Title":["St. Olavs Hospital HF"],"TitleWithPath":["St. Olavs Hospital HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[104284],"ParentUnitId":[100320],"HasDatabase":[true],"ExternalId":[104284],"HealthUnitId":{},"Title":["Klinikk for Hjertemedisin"],"TitleWithPath":["St. Olavs Hospital HF - Klinikk for Hjertemedisin"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[106944],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[106944],"HealthUnitId":{},"Title":["AHUS Gardermoen"],"TitleWithPath":["AHUS Gardermoen"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[4214492],"ParentUnitId":[106944],"HasDatabase":[true],"ExternalId":[4214492],"HealthUnitId":{},"Title":["Hjertemedisinsk avdeling"],"TitleWithPath":["AHUS Gardermoen - Hjertemedisinsk avdeling"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}}]} From de1fc8547ff467b832d7585c425f30705143e533 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 27 Sep 2022 08:41:15 +0200 Subject: [PATCH 10/79] unit attributes from access tree --- NAMESPACE | 1 + R/accessTree.R | 31 +++++++++++++++ R/userAttribute.R | 59 ++++++++++++++++++++++++++-- data-raw/accesstree.R | 72 +++++++++++++++++----------------- inst/extdata/accesstree.json | 2 +- inst/rapbaseConfig.yml | 15 +++++++ man/unitAttribute.Rd | 26 ++++++++++++ tests/testthat/test-userInfo.R | 34 +++++++++++++--- 8 files changed, 195 insertions(+), 45 deletions(-) create mode 100644 R/accessTree.R create mode 100644 man/unitAttribute.Rd diff --git a/NAMESPACE b/NAMESPACE index c07afb87..9066f151 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -78,6 +78,7 @@ export(statsGuideUI) export(statsInput) export(statsServer) export(statsUI) +export(unitAttribute) export(upgradeAutoReportData) export(userInfo) export(writeAutoReportData) diff --git a/R/accessTree.R b/R/accessTree.R new file mode 100644 index 00000000..8923d05b --- /dev/null +++ b/R/accessTree.R @@ -0,0 +1,31 @@ +accesstree <- function(unit, + what, + file = NULL, + path = Sys.getenv("R_RAP_CONFIG_PATH")) { + + conf <- getConfig(fileName = "rapbaseConfig.yml")$accesstree + + if (is.null(file)) { + file <- conf$file + } + + stopifnot(file.exists(file.path(path, file))) + if (!what %in% names(conf$list)) { + stop( + paste0( + "Argument what is not one of '", + paste0(names(conf$list), collapse = "', '"), + "'" + ) + ) + } + + d <- jsonlite::read_json(file.path(path, file)) %>% + unlist() + + as.vector( + d[ + names(d) == conf$list[[what]] + ][as.vector(d[names(d) == conf$list$unit]) == unit] + ) +} diff --git a/R/userAttribute.R b/R/userAttribute.R index 01a8a914..b6815ff8 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -140,9 +140,9 @@ userInfo <- function( if (context %in% c("QAC", "PRODUCTIONC")) { user <- Sys.getenv("SHINYPROXY_USERNAME") - groups <- shinySession$userData$defaultGroup - resh_id <- Sys.getenv("USERORGID") - role <- Sys.getenv("USERROLE") + groups <- Sys.getenv("SHINYPROXY_USERGROUPS") + resh_id <- unitAttribute(Sys.getenv("USERORGID"), "resh") + role <- unitAttribute(Sys.getenv("USERORGID"), "role") email <- Sys.getenv("USEREMAIL") full_name <- parse(text = paste0("'", Sys.getenv("USERFULLNAME"), "'"))[[1]] @@ -162,6 +162,59 @@ userInfo <- function( } +#' Get unit attributes from an access tree file +#' +#' Obtain organization unit attributes from an access tree JSON file +#' +#' @param unit Integer providing the look-up unit id +#' @param what Character string defining what to return for the given unit id +#' @param file Character string file name of the JSON file. Default values is +#' NULL in which case the corresponding value from rapbaseConfig.yml will be +#' used. +#' @param path Character string file path of the JSON file. Default value is +#' \code{Sys.getenv("R_RAP_CONFIG_PATH")}. +#' +#' @return The corresponding value of 'what'. +#' @export +unitAttribute <- function(unit, + what, + file = NULL, + path = Sys.getenv("R_RAP_CONFIG_PATH")) { + + conf <- getConfig(fileName = "rapbaseConfig.yml")$accesstree + + if (is.null(file)) { + file <- conf$file + } + + stopifnot(file.exists(file.path(path, file))) + if (!what %in% names(conf$list)) { + stop( + paste0( + "Argument what is not one of '", + paste0(names(conf$list), collapse = "', '"), + "'" + ) + ) + } + + d <- jsonlite::read_json(file.path(path, file)) %>% + unlist() + + ind <- as.vector(d[names(d) == conf$list$unit]) == unit + + if (all(!ind)) { + warning( + paste0( + "Unit '", unit, "' was not found! Hence, your request for '", what, + "' will return empty!" + ) + ) + } + as.vector(d[names(d) == conf$list[[what]]][ind]) +} + + #' Get user email from config or session object #' #' This is a helper function for \code{\link{userInfo}}. When used without a diff --git a/data-raw/accesstree.R b/data-raw/accesstree.R index 8059564d..c2045884 100644 --- a/data-raw/accesstree.R +++ b/data-raw/accesstree.R @@ -2,100 +2,100 @@ j <- ' { "AccessUnits": [ { - "UnitId": 100082, + "UnitId": 1, "ParentUnitId": 0, "HasDatabase": true, "ExternalId": 100082, - "HealthUnitId": null, - "Title": "Helse Bergen HF", + "HealthUnitId": 100082, + "Title": "Helse Bergen HF - SC", "TitleWithPath": "Helse Bergen HF", "ValidFrom": null, "ValidTo": null, - "ExtraData": null + "ExtraData": "SC" }, { - "UnitId": 102966, - "ParentUnitId": 100082, + "UnitId": 2, + "ParentUnitId": 1, "HasDatabase": true, "ExternalId": 102966, - "HealthUnitId": null, - "Title": "HB Hjerteavdelingen", + "HealthUnitId": 102966, + "Title": "HB Hjerteavdelingen - LU", "TitleWithPath": "Helse Bergen HF - HB Hjerteavdelingen", "ValidFrom": null, "ValidTo": null, - "ExtraData": null + "ExtraData": "LU" }, { - "UnitId": 4001031, + "UnitId": 3, "ParentUnitId": 0, "HasDatabase": true, "ExternalId": 4001031, - "HealthUnitId": null, - "Title": "Oslo universitetssykehus HF", + "HealthUnitId": 4001031, + "Title": "Oslo universitetssykehus HF - SC", "TitleWithPath": "Oslo universitetssykehus HF", "ValidFrom": null, "ValidTo": null, - "ExtraData": null + "ExtraData": "SC" }, { - "UnitId": 700328, - "ParentUnitId": 4001031, + "UnitId": 4, + "ParentUnitId": 3, "HasDatabase": true, "ExternalId": 700328, - "HealthUnitId": null, - "Title": "Hjerte-, lunge- og karklinikken", + "HealthUnitId": 700328, + "Title": "Hjerte-, lunge- og karklinikken - LU", "TitleWithPath": "Oslo universitetssykehus HF - Hjerte-, lunge- og karklinikken", "ValidFrom": null, "ValidTo": null, - "ExtraData": null + "ExtraData": "LU" }, { - "UnitId": 100320, + "UnitId": 5, "ParentUnitId": 0, "HasDatabase": true, "ExternalId": 100320, - "HealthUnitId": null, - "Title": "St. Olavs Hospital HF", + "HealthUnitId": 100320, + "Title": "St. Olavs Hospital HF - SC", "TitleWithPath": "St. Olavs Hospital HF", "ValidFrom": null, "ValidTo": null, - "ExtraData": null + "ExtraData": "SC" }, { - "UnitId": 104284, - "ParentUnitId": 100320, + "UnitId": 6, + "ParentUnitId": 5, "HasDatabase": true, "ExternalId": 104284, - "HealthUnitId": null, - "Title": "Klinikk for Hjertemedisin", + "HealthUnitId": 104284, + "Title": "Klinikk for Hjertemedisin - LU", "TitleWithPath": "St. Olavs Hospital HF - Klinikk for Hjertemedisin", "ValidFrom": null, "ValidTo": null, - "ExtraData": null + "ExtraData": "LU" }, { - "UnitId": 106944, + "UnitId": 7, "ParentUnitId": 0, "HasDatabase": true, "ExternalId": 106944, - "HealthUnitId": null, - "Title": "AHUS Gardermoen", + "HealthUnitId": 106944, + "Title": "AHUS Gardermoen - SC", "TitleWithPath": "AHUS Gardermoen", "ValidFrom": null, "ValidTo": null, - "ExtraData": null + "ExtraData": "SC" }, { - "UnitId": 4214492, - "ParentUnitId": 106944, + "UnitId": 8, + "ParentUnitId": 7, "HasDatabase": true, "ExternalId": 4214492, - "HealthUnitId": null, - "Title": "Hjertemedisinsk avdeling", + "HealthUnitId": 4214492, + "Title": "Hjertemedisinsk avdeling - LU", "TitleWithPath": "AHUS Gardermoen - Hjertemedisinsk avdeling", "ValidFrom": null, "ValidTo": null, - "ExtraData": null + "ExtraData": "LU" } ] } diff --git a/inst/extdata/accesstree.json b/inst/extdata/accesstree.json index 6e41e341..73cf6adf 100644 --- a/inst/extdata/accesstree.json +++ b/inst/extdata/accesstree.json @@ -1 +1 @@ -{"AccessUnits":[{"UnitId":[100082],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[100082],"HealthUnitId":{},"Title":["Helse Bergen HF"],"TitleWithPath":["Helse Bergen HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[102966],"ParentUnitId":[100082],"HasDatabase":[true],"ExternalId":[102966],"HealthUnitId":{},"Title":["HB Hjerteavdelingen"],"TitleWithPath":["Helse Bergen HF - HB Hjerteavdelingen"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[4001031],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[4001031],"HealthUnitId":{},"Title":["Oslo universitetssykehus HF"],"TitleWithPath":["Oslo universitetssykehus HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[700328],"ParentUnitId":[4001031],"HasDatabase":[true],"ExternalId":[700328],"HealthUnitId":{},"Title":["Hjerte-, lunge- og karklinikken"],"TitleWithPath":["Oslo universitetssykehus HF - Hjerte-, lunge- og karklinikken"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[100320],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[100320],"HealthUnitId":{},"Title":["St. Olavs Hospital HF"],"TitleWithPath":["St. Olavs Hospital HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[104284],"ParentUnitId":[100320],"HasDatabase":[true],"ExternalId":[104284],"HealthUnitId":{},"Title":["Klinikk for Hjertemedisin"],"TitleWithPath":["St. Olavs Hospital HF - Klinikk for Hjertemedisin"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[106944],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[106944],"HealthUnitId":{},"Title":["AHUS Gardermoen"],"TitleWithPath":["AHUS Gardermoen"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}},{"UnitId":[4214492],"ParentUnitId":[106944],"HasDatabase":[true],"ExternalId":[4214492],"HealthUnitId":{},"Title":["Hjertemedisinsk avdeling"],"TitleWithPath":["AHUS Gardermoen - Hjertemedisinsk avdeling"],"ValidFrom":{},"ValidTo":{},"ExtraData":{}}]} +{"AccessUnits":[{"UnitId":[1],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[100082],"HealthUnitId":[100082],"Title":["Helse Bergen HF - SC"],"TitleWithPath":["Helse Bergen HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[2],"ParentUnitId":[1],"HasDatabase":[true],"ExternalId":[102966],"HealthUnitId":[102966],"Title":["HB Hjerteavdelingen - LU"],"TitleWithPath":["Helse Bergen HF - HB Hjerteavdelingen"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]},{"UnitId":[3],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[4001031],"HealthUnitId":[4001031],"Title":["Oslo universitetssykehus HF - SC"],"TitleWithPath":["Oslo universitetssykehus HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[4],"ParentUnitId":[3],"HasDatabase":[true],"ExternalId":[700328],"HealthUnitId":[700328],"Title":["Hjerte-, lunge- og karklinikken - LU"],"TitleWithPath":["Oslo universitetssykehus HF - Hjerte-, lunge- og karklinikken"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]},{"UnitId":[5],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[100320],"HealthUnitId":[100320],"Title":["St. Olavs Hospital HF - SC"],"TitleWithPath":["St. Olavs Hospital HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[6],"ParentUnitId":[5],"HasDatabase":[true],"ExternalId":[104284],"HealthUnitId":[104284],"Title":["Klinikk for Hjertemedisin - LU"],"TitleWithPath":["St. Olavs Hospital HF - Klinikk for Hjertemedisin"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]},{"UnitId":[7],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[106944],"HealthUnitId":[106944],"Title":["AHUS Gardermoen - SC"],"TitleWithPath":["AHUS Gardermoen"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[8],"ParentUnitId":[7],"HasDatabase":[true],"ExternalId":[4214492],"HealthUnitId":[4214492],"Title":["Hjertemedisinsk avdeling - LU"],"TitleWithPath":["AHUS Gardermoen - Hjertemedisinsk avdeling"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]}]} diff --git a/inst/rapbaseConfig.yml b/inst/rapbaseConfig.yml index 03bf58dc..9e8d406f 100644 --- a/inst/rapbaseConfig.yml +++ b/inst/rapbaseConfig.yml @@ -94,3 +94,18 @@ db : user : rapbase pass : rapbase disp : ForTestingOnly + +## Access tree +accesstree: + file: accesstree.json + list: + unit: AccessUnits.UnitId + resh: AccessUnits.HealthUnitId + role: AccessUnits.ExtraData + parent: AccessUnits.ParentUnitId + database: AccessUnits.HasDatabase + external: AccessUnits.ExternalId + title: AccessUnits.Title + titlewithpath: AccessUnits.TitleWithPath + validfrom: AccessUnits.ValidFrom + validto: AccessUnits.ValidTo diff --git a/man/unitAttribute.Rd b/man/unitAttribute.Rd new file mode 100644 index 00000000..dd01ea69 --- /dev/null +++ b/man/unitAttribute.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/userAttribute.R +\name{unitAttribute} +\alias{unitAttribute} +\title{Get unit attributes from an access tree file} +\usage{ +unitAttribute(unit, what, file = NULL, path = Sys.getenv("R_RAP_CONFIG_PATH")) +} +\arguments{ +\item{unit}{Integer providing the look-up unit id} + +\item{what}{Character string defining what to return for the given unit id} + +\item{file}{Character string file name of the JSON file. Default values is +NULL in which case the corresponding value from rapbaseConfig.yml will be +used.} + +\item{path}{Character string file path of the JSON file. Default value is +\code{Sys.getenv("R_RAP_CONFIG_PATH")}.} +} +\value{ +The corresponding value of 'what'. +} +\description{ +Obtain organization unit attributes from an access tree JSON file +} diff --git a/tests/testthat/test-userInfo.R b/tests/testthat/test-userInfo.R index 3b9c1a6b..1132d91c 100644 --- a/tests/testthat/test-userInfo.R +++ b/tests/testthat/test-userInfo.R @@ -130,13 +130,37 @@ test_that("Function can handle redefined contexts", { # New: container instance for QA and PRODUCTION contexts shinySession$userData$defaultGroup <- "myDefaultGroup" + +Sys.setenv(R_RAP_CONFIG_PATH = tempdir()) +file.copy( + system.file( + c("rapbaseConfig.yml", "extdata/accesstree.json"), package = "rapbase" + ), + Sys.getenv("R_RAP_CONFIG_PATH") +) + +test_that("error is returned when attributes file does not exist", { + expect_error(unitAttribute(1, "role", file = "does_not_exist.json")) +}) + +test_that("error is returned when unknown attribute", { + expect_error(unitAttribute(1, "userRole")) +}) + +test_that("warning is given when unit does not exist", { + expect_warning(unitAttribute(100000, "role")) +}) + +test_that("unit attributes can be obtained", { + expect_equal(unitAttribute(2, "role"), "LU") +}) + with_envvar( new = c( "R_RAP_INSTANCE" = "QAC", "SHINYPROXY_USERNAME" = "userc", "SHINYPROXY_USERGROUPS" = "groupsc", - "USERORGID" = "13579", - "USERROLE" = "rolec", + "USERORGID" = "2", "USEREMAIL" = "userc@container.no", "USERFULLNAME" = "User Container", "USERPHONE" = "+4787654321" @@ -144,9 +168,9 @@ with_envvar( code = { test_that("User attribs can be fetched in container instance (QA, PROD)", { expect_equal(getUserName(shinySession), "userc") - expect_equal(getUserGroups(shinySession), "myDefaultGroup") - expect_equal(getUserReshId(shinySession), "13579") - expect_equal(getUserRole(shinySession), "rolec") + expect_equal(getUserGroups(shinySession), "groupsc") + expect_equal(getUserReshId(shinySession), "102966") + expect_equal(getUserRole(shinySession), "LU") expect_equal(getUserEmail(shinySession), "userc@container.no") expect_equal(getUserFullName(shinySession), "User Container") expect_equal(getUserPhone(shinySession), "+4787654321") From b90e07aebe4331079ebf6ba5f1232128458c69b2 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 27 Sep 2022 09:13:56 +0200 Subject: [PATCH 11/79] throw away leftovers --- R/accessTree.R | 31 ------------------------------- 1 file changed, 31 deletions(-) delete mode 100644 R/accessTree.R diff --git a/R/accessTree.R b/R/accessTree.R deleted file mode 100644 index 8923d05b..00000000 --- a/R/accessTree.R +++ /dev/null @@ -1,31 +0,0 @@ -accesstree <- function(unit, - what, - file = NULL, - path = Sys.getenv("R_RAP_CONFIG_PATH")) { - - conf <- getConfig(fileName = "rapbaseConfig.yml")$accesstree - - if (is.null(file)) { - file <- conf$file - } - - stopifnot(file.exists(file.path(path, file))) - if (!what %in% names(conf$list)) { - stop( - paste0( - "Argument what is not one of '", - paste0(names(conf$list), collapse = "', '"), - "'" - ) - ) - } - - d <- jsonlite::read_json(file.path(path, file)) %>% - unlist() - - as.vector( - d[ - names(d) == conf$list[[what]] - ][as.vector(d[names(d) == conf$list$unit]) == unit] - ) -} From c03c1a15980e7d112ff0aab9465557ffa0d4afe4 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 27 Sep 2022 09:17:21 +0200 Subject: [PATCH 12/79] missing on site docs --- _pkgdown.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/_pkgdown.yml b/_pkgdown.yml index 4613ffd6..0743e947 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -44,6 +44,7 @@ reference: - getUserPhone - getUserEmail - userInfo + - unitAttribute - title: Logging desc: > From f256821fbfd5c0bb39b958f58d18b60b416e0d5b Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Wed, 28 Sep 2022 16:32:55 +0200 Subject: [PATCH 13/79] under construction container org/role stuff --- NAMESPACE | 1 + R/userAttribute.R | 77 ++++++++++++++++++++++++++++++++++ man/setContainerEnv.Rd | 25 +++++++++++ tests/testthat/test-userInfo.R | 74 +++++++++++++++++++++++++++++++- 4 files changed, 175 insertions(+), 2 deletions(-) create mode 100644 man/setContainerEnv.Rd diff --git a/NAMESPACE b/NAMESPACE index 9066f151..73116e0b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -71,6 +71,7 @@ export(sanitizeLog) export(saveStagingData) export(selectListPubkey) export(sendEmail) +export(setContainerEnv) export(statsApp) export(statsGuideApp) export(statsGuideServer) diff --git a/R/userAttribute.R b/R/userAttribute.R index b6815ff8..400805e7 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -162,6 +162,83 @@ userInfo <- function( } +#' IN CONSTRUCTION: Get environmental variables for for container apps. +#' +#' For apps running as containers particular environment variables must be +#' defined for an orderly handling of dynamic user privileges. This function +#' makes use of information stored in the shiny session environment and in +#' environmental variables defined by shinyproxy to set (new) environment +#' variables APP_ORG and APP_ROLE that defines the current role and organization +#' for the app. +#' +#' @param shinySession A shiny session object +#' @param unit Integer providing the look-up unit id. Default value is NULL in +#' which case the first viable option will be used +#' +#' @return Invisible NULL on success +#' @export + +setContainerEnv <- function(shinySession, unit = NULL) { + + stopifnot(!is.null(shinySession)) + + if (is.null(shinySession$userData$packageName) || + shinySession$userData$packageName == "") { + stop(paste( + "Shiny session environment does not contain the package name. Until", + "furhter notice please add the following code in the server function:", + "'session$userData$packageName <- packageName()'." + )) + } + + if (Sys.getenv("SHINYPROXY_USERGROUPS") == "" || + Sys.getenv("USERORGID") == "") { + stop(paste( + "Environmental variables SHINYPROXY_USERGROUPS and USERORGID must both", + "be set!" + )) + } + + # make vectors of vals + orgs <- unlist( + strsplit( + gsub("\\s|\\[|\\]", "", Sys.getenv("USERORGID")), + "," + ) + ) + apps <- unlist( + strsplit( + gsub("\\s|\\[|\\]", "", Sys.getenv("SHINYPROXY_USERGROUPS")), + "," + ) + ) + + if(length(orgs) != length(apps)) { + stop(paste( + "Vectors obtained from SHINYPROXY_USERGROUPS and USERORGID are of", + "different lengths. Hence, correspondence cannot be anticipated." + )) + } + + # NB Anticipate that element positions in vectors do correspond! + ## filter by this app + app <- apps[apps == shinySession$userData$packageName] + org <- orgs[apps == shinySession$userData$packageName] + + ## return all or filter current unit when provided + if(is.null(unit)) { + list( + app = app, + org = org + ) + } else { + list( + app = app[org == unit], + org = org[org == unit] + ) + } +} + #' Get unit attributes from an access tree file #' #' Obtain organization unit attributes from an access tree JSON file diff --git a/man/setContainerEnv.Rd b/man/setContainerEnv.Rd new file mode 100644 index 00000000..8b9ef9c2 --- /dev/null +++ b/man/setContainerEnv.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/userAttribute.R +\name{setContainerEnv} +\alias{setContainerEnv} +\title{Set environmental variables for for container apps.} +\usage{ +setContainerEnv(shinySession, unit = NULL) +} +\arguments{ +\item{shinySession}{A shiny session object} + +\item{unit}{Integer providing the look-up unit id. Default value is NULL in +which case the first viable option will be used} +} +\value{ +Invisible NULL on success +} +\description{ +For apps running as containers particular environment variables must be +defined for an orderly handling of dynamic user privileges. This function +makes use of information stored in the shiny session environment and in +environmental variables defined by shinyproxy to set (new) environment +variables APP_ORG and APP_ROLE that defines the current role and organization +for the app. +} diff --git a/tests/testthat/test-userInfo.R b/tests/testthat/test-userInfo.R index 1132d91c..e38940c4 100644 --- a/tests/testthat/test-userInfo.R +++ b/tests/testthat/test-userInfo.R @@ -129,8 +129,6 @@ test_that("Function can handle redefined contexts", { }) # New: container instance for QA and PRODUCTION contexts -shinySession$userData$defaultGroup <- "myDefaultGroup" - Sys.setenv(R_RAP_CONFIG_PATH = tempdir()) file.copy( system.file( @@ -139,6 +137,78 @@ file.copy( Sys.getenv("R_RAP_CONFIG_PATH") ) +## setContainerEnv +test_that("errors are returned when insufficient shiny session environment", { + expect_error(setContainerEnv(NULL)) + expect_error( + setContainerEnv(shinySession), + regexp = "Shiny session environment does not contain the package name") +}) + +shinySession$userData$packageName <- "app1" + +with_envvar( + new = c( + "SHINYPROXY_USERGROUPS" = "groupsc" + ), + code = { + test_that("errors are returned when insufficient system environment", { + expect_error( + setContainerEnv(shinySession), + regexp = "Environmental variables SHINYPROXY_USERGROUPS and USERORGID") + }) + } +) + +with_envvar( + new = c( + "USERORGID" = "1" + ), + code = { + test_that("errors are returned when insufficient system environment", { + expect_error( + setContainerEnv(shinySession), + regexp = "Environmental variables SHINYPROXY_USERGROUPS and USERORGID") + }) + } +) + +with_envvar( + new = c( + "SHINYPROXY_USERGROUPS" = "app1,app2", + "USERORGID" = "[1]" + ), + code = { + test_that("error is returned when environment elements are not equal", { + expect_error( + setContainerEnv(shinySession), + regexp = "Vectors obtained from SHINYPROXY_USERGROUPS and USERORGID") + }) + } +) + +with_envvar( + new = c( + "SHINYPROXY_USERGROUPS" = "app1,app1,app2,app2", + "USERORGID" = "[1, 2, 3, 4]" + ), + code = { + test_that("apps and orgs are returned correspondingly when unit = NULL", { + expect_true(class(setContainerEnv(shinySession)) == "list") + expect_true( + length(setContainerEnv(shinySession)$app) == + length(setContainerEnv(shinySession)$org) + ) + expect_true(setContainerEnv(shinySession)$app[1] == "app1") + expect_true(setContainerEnv(shinySession)$app[2] == "app1") + expect_true(setContainerEnv(shinySession)$org[1] == "1") + expect_true(setContainerEnv(shinySession)$org[2] == "2") + }) + } +) + + +## unitAttribute test_that("error is returned when attributes file does not exist", { expect_error(unitAttribute(1, "role", file = "does_not_exist.json")) }) From 36b8aa054496187b7b37495e69a5fc1a4c88f28d Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 29 Sep 2022 10:32:09 +0200 Subject: [PATCH 14/79] opt in for selecting org/role in widget --- R/moduleNavbarWidget.R | 56 ++++++++++++++++++++++++++++++++++-------- 1 file changed, 46 insertions(+), 10 deletions(-) diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index 1607f2af..34909ddb 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -10,14 +10,17 @@ #' #' @param id Character string providing module namespace #' @param addUserInfo Logical defining if an "about" hyperlink is to be added +#' @param selectOrganization Logical providing option for selecting among +#' available organizations. #' @param orgName Character string naming the organization #' @param caller Character string naming the environment this function was -#' called from. Default value is \code{environmentName(topenv(parent.frame()))}. -#' The value is used to display the current version of the R package -#' representing the registry at Rapporteket. If this module is called from -#' exported functions in the registry R package use the default value. If the -#' module is called from outside the registry environment \code{caller} must be -#' set to the actual name of the R package. +#' called from. Default value is +#' \code{environmentName(topenv(parent.frame()))}. The value is used to +#' display the current version of the R package representing the registry at +#' Rapporteket. If this module is called from exported functions in th +#' registry R package use the default value. If the module is called from +#' outside the registry environment \code{caller} must be set to the actual +#' name of the R package. #' #' @return Shiny objects, mostly. Helper functions may return other stuff too. #' @name navbarWidget @@ -50,7 +53,9 @@ NULL #' @rdname navbarWidget #' @export -navbarWidgetInput <- function(id, addUserInfo = TRUE) { +navbarWidgetInput <- function(id, + addUserInfo = TRUE, + selectOrganization = FALSE) { shiny::addResourcePath("rap", system.file("www", package = "rapbase")) shiny::tagList( @@ -93,6 +98,24 @@ navbarWidgetServer <- function( confirmButtonText = rapbase::noOptOutOk() ) }) + + # Select organization in widget + shiny::observeEvent(input$selectOrganization, { + shinyalert::shinyalert( + "Velg organisasjon", + paste( + "Velg avdeling og rolle du ønsker å representere for", orgName, + "i Rapporteket og trykk OK.", + "Dine valgmuligheter er basert på de tilganger som er satt.", + "Ta kontakt med registeret om du mener at lista over valg", + "ikke er riktg." + ), + type = "", imageUrl = "rap/logo.svg", + closeOnEsc = FALSE, + closeOnClickOutside = FALSE, + confirmButtonText = "OK" + ) + }) }) } @@ -155,9 +178,10 @@ navbarWidgetApp <- function(orgName = "Org Name") { #' @param user String providing the name of the user #' @param organization String providing the organization of the user #' @param addUserInfo Logical defining whether a user data pop-up is to be part -#' of the widget (TRUE) or not (FALSE, default) +#' of the widget (TRUE) or not (FALSE, default) +#' @param selectOrganization Logical if organization can be selected. #' @param namespace Character string providing the namespace to use, if any. -#' Defaults is \code{NULL} in which case no namespace will be applied. +#' Defaults is \code{NULL} in which case no namespace will be applied. #' #' @return Ready made html script #' @export @@ -167,6 +191,7 @@ navbarWidgetApp <- function(orgName = "Org Name") { appNavbarUserWidget <- function(user = "Undefined person", organization = "Undefined organization", addUserInfo = FALSE, + selectOrganization = FALSE, namespace = NULL) { if (addUserInfo) { userInfo <- shiny::tags$a( @@ -179,6 +204,17 @@ appNavbarUserWidget <- function(user = "Undefined person", userInfo <- character() } + if (selectOrganization) { + org <- shiny::tags$a( + id = shiny::NS(namespace, "selectOrganization"), + href = "#", + class = "action-button", + shiny::HTML(gsub("\\n", "", organization)) + ) + } else { + org <- organization + } + txtWidget <- paste0( "var header = $('.navbar> .container-fluid');\n", @@ -186,7 +222,7 @@ appNavbarUserWidget <- function(user = "Undefined person", "style=\"float:right;vertical-align:super;font-size:65%\">", userInfo, user, - organization, + org, "');\n", "console.log(header)" ) From 99cf92e5311e8622924014a811113548d4076cbd Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 29 Sep 2022 15:26:18 +0200 Subject: [PATCH 15/79] restructure --- NAMESPACE | 2 +- R/moduleNavbarWidget.R | 30 ++++++++++++++++++++++-------- man/getContainerPrivileges.Rd | 25 +++++++++++++++++++++++++ man/setContainerEnv.Rd | 25 ------------------------- 4 files changed, 48 insertions(+), 34 deletions(-) create mode 100644 man/getContainerPrivileges.Rd delete mode 100644 man/setContainerEnv.Rd diff --git a/NAMESPACE b/NAMESPACE index 73116e0b..1789c571 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -31,6 +31,7 @@ export(filterAutoRep) export(findNextRunDate) export(fireInTheHole) export(getConfig) +export(getContainerPrivileges) export(getGithub) export(getRapPackages) export(getRegs) @@ -71,7 +72,6 @@ export(sanitizeLog) export(saveStagingData) export(selectListPubkey) export(sendEmail) -export(setContainerEnv) export(statsApp) export(statsGuideApp) export(statsGuideServer) diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index 34909ddb..5fc7711e 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -63,6 +63,7 @@ navbarWidgetInput <- function(id, user = shiny::uiOutput(shiny::NS(id, "name")), organization = shiny::uiOutput(shiny::NS(id, "affiliation")), addUserInfo = addUserInfo, + selectOrganization = selectOrganization, namespace = id ), shiny::tags$head( @@ -101,14 +102,27 @@ navbarWidgetServer <- function( # Select organization in widget shiny::observeEvent(input$selectOrganization, { + privs <- getContainerPrivileges(caller) + choices <- privs$unit + names(choices) <- paste0(privs$name, " (", privs$org, ") - ", privs$role) shinyalert::shinyalert( - "Velg organisasjon", - paste( - "Velg avdeling og rolle du ønsker å representere for", orgName, - "i Rapporteket og trykk OK.", - "Dine valgmuligheter er basert på de tilganger som er satt.", - "Ta kontakt med registeret om du mener at lista over valg", - "ikke er riktg." + html = TRUE, + title = "Velg organisasjon og rolle", + text = shiny::tagList( + shiny::p( + paste( + "Velg organisasjon og rolle du ønsker å representere for", + orgName, "i Rapporteket og trykk OK.", + "Dine valgmuligheter er basert på de tilganger som er satt.", + "Ta kontakt med registeret om du mener at lista over valg", + "ikke er riktg." + ) + ), + shiny::selectInput( + session$ns("org"), + "", + choices + ) ), type = "", imageUrl = "rap/logo.svg", closeOnEsc = FALSE, @@ -128,7 +142,7 @@ navbarWidgetApp <- function(orgName = "Org Name") { shiny::tabPanel( "Testpanel", shiny::mainPanel( - navbarWidgetInput("testWidget") + navbarWidgetInput("testWidget", selectOrganization = TRUE) ) ) ) diff --git a/man/getContainerPrivileges.Rd b/man/getContainerPrivileges.Rd new file mode 100644 index 00000000..de295be8 --- /dev/null +++ b/man/getContainerPrivileges.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/userAttribute.R +\name{getContainerPrivileges} +\alias{getContainerPrivileges} +\title{IN CONSTRUCTION: Get environmental variables for for container apps.} +\usage{ +getContainerPrivileges(group, unit = NULL) +} +\arguments{ +\item{group}{Character string providing the name of the app R package name. +The term "group" is used to relate to the environmental variable +SHINYPROXY_USERGROUPS that corresponds to the apps a given user can access.} + +\item{unit}{Integer providing the look-up unit id. Default value is NULL in +which case all privileges for \code{group} are returned.} +} +\value{ +List of privileges +} +\description{ +For apps running as containers particular environment variables must be +defined for an orderly handling of dynamic user privileges. This function +makes use of environmental variables defined by shinyproxy to provide +available privileges for the shiny application +} diff --git a/man/setContainerEnv.Rd b/man/setContainerEnv.Rd deleted file mode 100644 index 8b9ef9c2..00000000 --- a/man/setContainerEnv.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/userAttribute.R -\name{setContainerEnv} -\alias{setContainerEnv} -\title{Set environmental variables for for container apps.} -\usage{ -setContainerEnv(shinySession, unit = NULL) -} -\arguments{ -\item{shinySession}{A shiny session object} - -\item{unit}{Integer providing the look-up unit id. Default value is NULL in -which case the first viable option will be used} -} -\value{ -Invisible NULL on success -} -\description{ -For apps running as containers particular environment variables must be -defined for an orderly handling of dynamic user privileges. This function -makes use of information stored in the shiny session environment and in -environmental variables defined by shinyproxy to set (new) environment -variables APP_ORG and APP_ROLE that defines the current role and organization -for the app. -} From e542f71a382e3b439c402c17461f6bd798dee608 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 29 Sep 2022 15:27:09 +0200 Subject: [PATCH 16/79] test container approach --- R/userAttribute.R | 86 +++++++++++++++++++--------------- man/appNavbarUserWidget.Rd | 3 ++ man/navbarWidget.Rd | 18 ++++--- tests/testthat/test-userInfo.R | 76 +++++++++++++++++++++--------- 4 files changed, 114 insertions(+), 69 deletions(-) diff --git a/R/userAttribute.R b/R/userAttribute.R index 400805e7..c041811f 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -140,13 +140,18 @@ userInfo <- function( if (context %in% c("QAC", "PRODUCTIONC")) { user <- Sys.getenv("SHINYPROXY_USERNAME") - groups <- Sys.getenv("SHINYPROXY_USERGROUPS") - resh_id <- unitAttribute(Sys.getenv("USERORGID"), "resh") - role <- unitAttribute(Sys.getenv("USERORGID"), "role") email <- Sys.getenv("USEREMAIL") full_name <- parse(text = paste0("'", Sys.getenv("USERFULLNAME"), "'"))[[1]] phone <- Sys.getenv("USERPHONE") + # pick the first of available user privileges + privs <- getContainerPrivileges( + group = environmentName(topenv(parent.frame())) + ) + privs <- as.data.frame(privs)[1, ] + groups <- privs$group + resh_id <- privs$org + role <- privs$role } } @@ -166,30 +171,21 @@ userInfo <- function( #' #' For apps running as containers particular environment variables must be #' defined for an orderly handling of dynamic user privileges. This function -#' makes use of information stored in the shiny session environment and in -#' environmental variables defined by shinyproxy to set (new) environment -#' variables APP_ORG and APP_ROLE that defines the current role and organization -#' for the app. +#' makes use of environmental variables defined by shinyproxy to provide +#' available privileges for the shiny application #' -#' @param shinySession A shiny session object +#' @param group Character string providing the name of the app R package name. +#' The term "group" is used to relate to the environmental variable +#' SHINYPROXY_USERGROUPS that corresponds to the apps a given user can access. #' @param unit Integer providing the look-up unit id. Default value is NULL in -#' which case the first viable option will be used +#' which case all privileges for \code{group} are returned. #' -#' @return Invisible NULL on success +#' @return List of privileges #' @export -setContainerEnv <- function(shinySession, unit = NULL) { +getContainerPrivileges <- function(group, unit = NULL) { - stopifnot(!is.null(shinySession)) - - if (is.null(shinySession$userData$packageName) || - shinySession$userData$packageName == "") { - stop(paste( - "Shiny session environment does not contain the package name. Until", - "furhter notice please add the following code in the server function:", - "'session$userData$packageName <- packageName()'." - )) - } + stopifnot(group %in% utils::installed.packages()[, 1]) if (Sys.getenv("SHINYPROXY_USERGROUPS") == "" || Sys.getenv("USERORGID") == "") { @@ -200,20 +196,21 @@ setContainerEnv <- function(shinySession, unit = NULL) { } # make vectors of vals - orgs <- unlist( + units <- unlist( strsplit( gsub("\\s|\\[|\\]", "", Sys.getenv("USERORGID")), "," ) ) - apps <- unlist( + + groups <- unlist( strsplit( gsub("\\s|\\[|\\]", "", Sys.getenv("SHINYPROXY_USERGROUPS")), "," ) ) - if(length(orgs) != length(apps)) { + if(length(units) != length(groups)) { stop(paste( "Vectors obtained from SHINYPROXY_USERGROUPS and USERORGID are of", "different lengths. Hence, correspondence cannot be anticipated." @@ -221,22 +218,33 @@ setContainerEnv <- function(shinySession, unit = NULL) { } # NB Anticipate that element positions in vectors do correspond! - ## filter by this app - app <- apps[apps == shinySession$userData$packageName] - org <- orgs[apps == shinySession$userData$packageName] - - ## return all or filter current unit when provided - if(is.null(unit)) { - list( - app = app, - org = org - ) - } else { - list( - app = app[org == unit], - org = org[org == unit] - ) + ## filter by this group + units <- units[groups == group] + groups <- groups[groups == group] + + ## restrict when unit is provided + if(!is.null(unit)) { + groups <- groups[units == unit] + units <- units[units == unit] + } + + # Look up org, role and unit name + org <- vector() + role <- vector() + name <- vector() + for (i in seq_len(length(units))) { + org[i] <- unitAttribute(units[i], "resh") + role[i] <- unitAttribute(units[i], "role") + name[i] <- unitAttribute(units[i], "titlewithpath") } + + list( + group = groups, + unit = units, + org = org, + role = role, + name = name + ) } #' Get unit attributes from an access tree file diff --git a/man/appNavbarUserWidget.Rd b/man/appNavbarUserWidget.Rd index 92d809e8..1fa7920f 100644 --- a/man/appNavbarUserWidget.Rd +++ b/man/appNavbarUserWidget.Rd @@ -8,6 +8,7 @@ appNavbarUserWidget( user = "Undefined person", organization = "Undefined organization", addUserInfo = FALSE, + selectOrganization = FALSE, namespace = NULL ) } @@ -19,6 +20,8 @@ appNavbarUserWidget( \item{addUserInfo}{Logical defining whether a user data pop-up is to be part of the widget (TRUE) or not (FALSE, default)} +\item{selectOrganization}{Logical if organization can be selected.} + \item{namespace}{Character string providing the namespace to use, if any. Defaults is \code{NULL} in which case no namespace will be applied.} } diff --git a/man/navbarWidget.Rd b/man/navbarWidget.Rd index 7e8b1147..ed1c326d 100644 --- a/man/navbarWidget.Rd +++ b/man/navbarWidget.Rd @@ -7,7 +7,7 @@ \alias{navbarWidgetApp} \title{Shiny modules providing GUI and server logic for user info widget} \usage{ -navbarWidgetInput(id, addUserInfo = TRUE) +navbarWidgetInput(id, addUserInfo = TRUE, selectOrganization = FALSE) navbarWidgetServer( id, @@ -22,15 +22,19 @@ navbarWidgetApp(orgName = "Org Name") \item{addUserInfo}{Logical defining if an "about" hyperlink is to be added} +\item{selectOrganization}{Logical providing option for selecting among +available organizations.} + \item{orgName}{Character string naming the organization} \item{caller}{Character string naming the environment this function was -called from. Default value is \code{environmentName(topenv(parent.frame()))}. -The value is used to display the current version of the R package -representing the registry at Rapporteket. If this module is called from -exported functions in the registry R package use the default value. If the -module is called from outside the registry environment \code{caller} must be -set to the actual name of the R package.} +called from. Default value is +\code{environmentName(topenv(parent.frame()))}. The value is used to +display the current version of the R package representing the registry at +Rapporteket. If this module is called from exported functions in th +registry R package use the default value. If the module is called from +outside the registry environment \code{caller} must be set to the actual +name of the R package.} } \value{ Shiny objects, mostly. Helper functions may return other stuff too. diff --git a/tests/testthat/test-userInfo.R b/tests/testthat/test-userInfo.R index e38940c4..e6f937a6 100644 --- a/tests/testthat/test-userInfo.R +++ b/tests/testthat/test-userInfo.R @@ -137,24 +137,15 @@ file.copy( Sys.getenv("R_RAP_CONFIG_PATH") ) -## setContainerEnv -test_that("errors are returned when insufficient shiny session environment", { - expect_error(setContainerEnv(NULL)) - expect_error( - setContainerEnv(shinySession), - regexp = "Shiny session environment does not contain the package name") -}) - -shinySession$userData$packageName <- "app1" with_envvar( new = c( - "SHINYPROXY_USERGROUPS" = "groupsc" + "SHINYPROXY_USERGROUPS" = "rapbase" ), code = { test_that("errors are returned when insufficient system environment", { expect_error( - setContainerEnv(shinySession), + getContainerPrivileges("rapbase"), regexp = "Environmental variables SHINYPROXY_USERGROUPS and USERORGID") }) } @@ -167,7 +158,7 @@ with_envvar( code = { test_that("errors are returned when insufficient system environment", { expect_error( - setContainerEnv(shinySession), + getContainerPrivileges("rapbase"), regexp = "Environmental variables SHINYPROXY_USERGROUPS and USERORGID") }) } @@ -175,13 +166,13 @@ with_envvar( with_envvar( new = c( - "SHINYPROXY_USERGROUPS" = "app1,app2", + "SHINYPROXY_USERGROUPS" = "rapbase,utils", "USERORGID" = "[1]" ), code = { test_that("error is returned when environment elements are not equal", { expect_error( - setContainerEnv(shinySession), + getContainerPrivileges("rapbase"), regexp = "Vectors obtained from SHINYPROXY_USERGROUPS and USERORGID") }) } @@ -189,24 +180,63 @@ with_envvar( with_envvar( new = c( - "SHINYPROXY_USERGROUPS" = "app1,app1,app2,app2", + "SHINYPROXY_USERGROUPS" = "rapbase,rapbase,utils,utils", "USERORGID" = "[1, 2, 3, 4]" ), code = { - test_that("apps and orgs are returned correspondingly when unit = NULL", { - expect_true(class(setContainerEnv(shinySession)) == "list") + test_that("group and unit are returned correspondingly when unit = NULL", { + expect_true(class(getContainerPrivileges("rapbase")) == "list") expect_true( - length(setContainerEnv(shinySession)$app) == - length(setContainerEnv(shinySession)$org) + length(getContainerPrivileges("rapbase")$group) == + length(getContainerPrivileges("rapbase")$unit) ) - expect_true(setContainerEnv(shinySession)$app[1] == "app1") - expect_true(setContainerEnv(shinySession)$app[2] == "app1") - expect_true(setContainerEnv(shinySession)$org[1] == "1") - expect_true(setContainerEnv(shinySession)$org[2] == "2") + expect_true(length(getContainerPrivileges("rapbase")$group) == 2) + expect_true(getContainerPrivileges("rapbase")$group[1] == "rapbase") + expect_true(getContainerPrivileges("rapbase")$group[2] == "rapbase") + expect_true(getContainerPrivileges("rapbase")$unit[1] == "1") + expect_true(getContainerPrivileges("rapbase")$unit[2] == "2") }) } ) +with_envvar( + new = c( + "SHINYPROXY_USERGROUPS" = "rapbase,rapbase,utils,utils", + "USERORGID" = "[1, 2, 3, 4]" + ), + code = { + test_that("group and unit are returned correspondingly when unit is given", { + expect_true(class(getContainerPrivileges("rapbase")) == "list") + expect_true( + length(getContainerPrivileges("rapbase", unit = 2)$group) == + length(getContainerPrivileges("rapbase", unit = 2)$unit) + ) + expect_true( + getContainerPrivileges("rapbase", unit = 2)$unit == 2 + ) + expect_true( + getContainerPrivileges("utils", unit = 3)$unit == 3 + ) + }) + } +) + +with_envvar( + new = c( + "SHINYPROXY_USERGROUPS" = "rapbase,rapbase,utils,utils", + "USERORGID" = "[1, 2, 3, 4]" + ), + code = { + test_that("correct lookup values are provided", { + expect_true( + getContainerPrivileges("rapbase", unit = 2)$org == 102966 + ) + expect_true( + getContainerPrivileges("utils", unit = 3)$role == "SC" + ) + }) + } +) ## unitAttribute test_that("error is returned when attributes file does not exist", { From 7382f3a546973e103af3cc261af71078ceebba21 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 30 Sep 2022 15:49:04 +0200 Subject: [PATCH 17/79] work in progress --- R/moduleNavbarWidget.R | 64 +++++++++++++++++++++++++++++++++--------- R/userAttribute.R | 2 +- 2 files changed, 52 insertions(+), 14 deletions(-) diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index 5fc7711e..90bcd391 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -17,10 +17,10 @@ #' called from. Default value is #' \code{environmentName(topenv(parent.frame()))}. The value is used to #' display the current version of the R package representing the registry at -#' Rapporteket. If this module is called from exported functions in th -#' registry R package use the default value. If the module is called from -#' outside the registry environment \code{caller} must be set to the actual -#' name of the R package. +#' Rapporteket. If this module is called from exported functions in the +#' registry R package the default value should be applied. If the module is +#' called from outside the registry environment \code{caller} must be set to +#' the actual name of the R package. #' #' @return Shiny objects, mostly. Helper functions may return other stuff too. #' @name navbarWidget @@ -81,11 +81,19 @@ navbarWidgetServer <- function( ) { shiny::moduleServer(id, function(input, output, session) { - output$name <- shiny::renderText(rapbase::getUserFullName(session)) - output$affiliation <- shiny::renderText( - paste(orgName, getUserRole(session), sep = ", ") + + # to be populated further if and when inside an app container + rv <- shiny::reactiveValues( + group = NULL, + unit = NULL, + org = NULL, + role = getUserRole(session), + name = NULL ) + output$name <- shiny::renderText(rapbase::getUserFullName(session)) + output$affiliation <- shiny::renderText(paste(orgName, rv$role, sep = ", ")) + # User info in widget userInfo <- howWeDealWithPersonalData(session, callerPkg = caller) shiny::observeEvent(input$userInfo, { @@ -100,15 +108,19 @@ navbarWidgetServer <- function( ) }) - # Select organization in widget + # Select organization in widget (for container apps only) shiny::observeEvent(input$selectOrganization, { + + ## Start MOVE OUTSIDE observer when we are all containers ------------- ## privs <- getContainerPrivileges(caller) choices <- privs$unit names(choices) <- paste0(privs$name, " (", privs$org, ") - ", privs$role) + ## End MOVE OUTSIDE --------------------------------------------------- ## + shinyalert::shinyalert( html = TRUE, title = "Velg organisasjon og rolle", - text = shiny::tagList( + text = shiny::tagList(shiny::tagList( shiny::p( paste( "Velg organisasjon og rolle du ønsker å representere for", @@ -119,17 +131,38 @@ navbarWidgetServer <- function( ) ), shiny::selectInput( - session$ns("org"), + session$ns("unit"), "", choices ) - ), + )), type = "", imageUrl = "rap/logo.svg", closeOnEsc = FALSE, closeOnClickOutside = FALSE, confirmButtonText = "OK" ) }) + + shiny::observeEvent(input$unit, { + ## Start MOVE OUTSIDE observer when we are all containers ------------- ## + privs <- getContainerPrivileges(caller) + ## End MOVE OUTSIDE --------------------------------------------------- ## + rv$group <- privs$group[privs$unit == input$unit] + rv$unit <- privs$unit[privs$unit == input$unit] + rv$org <- privs$org[privs$unit == input$unit] + rv$role <- privs$role[privs$unit == input$unit] + rv$name <- privs$name[privs$unit == input$unit] + }) + + invisible( + list( + group = shiny::reactive(rv$group), + unit = shiny::reactive(rv$unit), + org = shiny::reactive(rv$org), + role = shiny::reactive(rv$role), + name = shiny::reactive(rv$name) + ) + ) }) } @@ -142,13 +175,17 @@ navbarWidgetApp <- function(orgName = "Org Name") { shiny::tabPanel( "Testpanel", shiny::mainPanel( - navbarWidgetInput("testWidget", selectOrganization = TRUE) + navbarWidgetInput( + "testWidget", + addUserInfo = FALSE, + selectOrganization = TRUE + ) ) ) ) ) server <- function(input, output, session) { - navbarWidgetServer("testWidget", orgName = orgName) + privs <- navbarWidgetServer("testWidget", orgName = orgName) } shiny::shinyApp(ui, server) @@ -207,6 +244,7 @@ appNavbarUserWidget <- function(user = "Undefined person", addUserInfo = FALSE, selectOrganization = FALSE, namespace = NULL) { + if (addUserInfo) { userInfo <- shiny::tags$a( id = shiny::NS(namespace, "userInfo"), diff --git a/R/userAttribute.R b/R/userAttribute.R index c041811f..8ed7a880 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -146,7 +146,7 @@ userInfo <- function( phone <- Sys.getenv("USERPHONE") # pick the first of available user privileges privs <- getContainerPrivileges( - group = environmentName(topenv(parent.frame())) + group = environmentName(topenv(parent.frame(2))) ) privs <- as.data.frame(privs)[1, ] groups <- privs$group From 1831328df574335f0fe48ab9c8a5ed76b84eadd5 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 3 Oct 2022 10:44:37 +0200 Subject: [PATCH 18/79] resolve group notion when shinyproxying --- R/userAttribute.R | 208 +++++++-------------------------- man/getUserEmail.Rd | 36 ------ man/getUserFullName.Rd | 36 ------ man/getUserGroups.Rd | 35 ------ man/getUserName.Rd | 35 ------ man/getUserPhone.Rd | 36 ------ man/getUserReshId.Rd | 35 ------ man/getUserRole.Rd | 35 ------ man/navbarWidget.Rd | 8 +- man/userAttribute.Rd | 51 ++++++++ man/userInfo.Rd | 7 +- tests/testthat/test-userInfo.R | 16 +-- 12 files changed, 112 insertions(+), 426 deletions(-) delete mode 100644 man/getUserEmail.Rd delete mode 100644 man/getUserFullName.Rd delete mode 100644 man/getUserGroups.Rd delete mode 100644 man/getUserName.Rd delete mode 100644 man/getUserPhone.Rd delete mode 100644 man/getUserReshId.Rd delete mode 100644 man/getUserRole.Rd create mode 100644 man/userAttribute.Rd diff --git a/R/userAttribute.R b/R/userAttribute.R index 8ed7a880..724e74f4 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -34,6 +34,9 @@ #' default set to \code{c("QA", "QAC", "PRODUCTION", "PRODUCTIONC")}. #' Duplication as seen by the "C" suffix will be needed as long as apps in #' question are to be run on both shiny-server and as standalone containers. +#' @param group Character string providing the name of the app R package name. +#' The term "group" is used to relate to the environmental variable +#' SHINYPROXY_USERGROUPS that corresponds to the apps a given user can access. #' #' @return String of single user data element #' @@ -47,7 +50,8 @@ userInfo <- function( shinySession = NULL, devContexts = c("DEV"), testContexts = c("TEST"), - prodContexts = c("QA", "QAC", "PRODUCTION", "PRODUCTIONC") + prodContexts = c("QA", "QAC", "PRODUCTION", "PRODUCTIONC"), + group = NULL ) { # stop helper function @@ -145,9 +149,7 @@ userInfo <- function( parse(text = paste0("'", Sys.getenv("USERFULLNAME"), "'"))[[1]] phone <- Sys.getenv("USERPHONE") # pick the first of available user privileges - privs <- getContainerPrivileges( - group = environmentName(topenv(parent.frame(2))) - ) + privs <- getContainerPrivileges(group) privs <- as.data.frame(privs)[1, ] groups <- privs$group resh_id <- privs$org @@ -300,19 +302,23 @@ unitAttribute <- function(unit, } -#' Get user email from config or session object -#' -#' This is a helper function for \code{\link{userInfo}}. When used without a -#' shiny session object calls to this function is made without any arguments. If -#' redefining contexts is needed, please use \code{\link{userInfo}} instead. +#' Get user attributes #' -#' @inheritParams userInfo +#' These are helper function for \code{\link{userInfo}}. When used without a +#' shiny session object calls to these functions is made without any arguments. +#' If redefining contexts is needed, please use \code{\link{userInfo}} instead. #' -#' @return String email address +#' @param shinySession A shiny session object. Default value is NULL +#' @param group Character string providing the name of the app R package name. +#' The term "group" is used to relate to the environmental variable +#' SHINYPROXY_USERGROUPS that corresponds to the apps a given user can access. +#' Default value is NULL but should always be set when shiny app is run as a +#' shinyproxy container. #' -#' @seealso \code{\link{getUserName}}, -#' \code{\link{getUserGroups}}, \code{\link{getUserReshId}}, -#' \code{\link{getUserEmail}} +#' @return String with user attribute +#' @name userAttribute +#' @aliases getUserEmail getUserFullName getUserGroups getUserName getUserPhone +#' getUserReshId getUserRole #' #' @examples #' \donttest{ @@ -320,180 +326,52 @@ unitAttribute <- function(unit, #' try(getUserEmail()) #' try(getUserEmail(shinySessionObject)) #' } -#' -#' @export - +NULL -getUserEmail <- function(shinySession = NULL) { - userInfo(shinySession, entity = "email") +#' @rdname userAttribute +#' @export +getUserEmail <- function(shinySession = NULL, group = NULL) { + userInfo(shinySession, entity = "email", group = group) } -#' Get user full name from config or session object -#' -#' This is a helper function for \code{\link{userInfo}}. When used without a -#' shiny session object calls to this function is made without any arguments. If -#' redefining contexts is needed, please use \code{\link{userInfo}} instead. -#' -#' @inheritParams userInfo -#' -#' @return String full name -#' -#' @seealso \code{\link{getUserName}}, -#' \code{\link{getUserGroups}}, \code{\link{getUserReshId}}, -#' \code{\link{getUserEmail}}, \code{\link{getUserPhone}} -#' -#' @examples -#' \donttest{ -#' # Requires a valid shiny session object -#' try(getUserFullName()) -#' try(getUserFullName(shinySessionObject)) -#' } -#' +#' @rdname userAttribute #' @export - - -getUserFullName <- function(shinySession = NULL) { - userInfo(shinySession, entity = "full_name") +getUserFullName <- function(shinySession = NULL, group = NULL) { + userInfo(shinySession, entity = "full_name", group = group) } -#' Get user groups from config or session object -#' -#' This is a helper function for \code{\link{userInfo}}. When used without a -#' shiny session object calls to this function is made without any arguments. If -#' redefining contexts is needed, please use \code{\link{userInfo}} instead. -#' -#' @inheritParams userInfo -#' -#' @return String user name -#' -#' @seealso \code{\link{getUserName}}, -#' \code{\link{getUserReshId}}, \code{\link{getUserRole}} -#' -#' @examples -#' \donttest{ -#' # Requires a valid shiny session object -#' try(getUserGroups()) -#' try(getUserGroups(shinySessionObject)) -#' } -#' +#' @rdname userAttribute #' @export - - -getUserGroups <- function(shinySession = NULL) { - userInfo(shinySession, entity = "groups") +getUserGroups <- function(shinySession = NULL, group = NULL) { + userInfo(shinySession, entity = "groups", group = group) } -#' Get user name from config or session object -#' -#' This is a helper function for \code{\link{userInfo}}. When used without a -#' shiny session object calls to this function is made without any arguments. If -#' redefining contexts is needed, please use \code{\link{userInfo}} instead. -#' -#' @inheritParams userInfo -#' -#' @return String user name -#' -#' @seealso \code{\link{getUserGroups}}, -#' \code{\link{getUserReshId}}, \code{\link{getUserRole}} -#' -#' @examples -#' \donttest{ -#' # Requires a valid shiny session object -#' try(getUserName()) -#' try(getUserName(shinySessionObject)) -#' } -#' +#' @rdname userAttribute #' @export - - -getUserName <- function(shinySession = NULL) { - userInfo(shinySession, entity = "user") +getUserName <- function(shinySession = NULL, group = NULL) { + userInfo(shinySession, entity = "user", group = group) } -#' Get user phone (number) from config or session object -#' -#' This is a helper function for \code{\link{userInfo}}. When used without a -#' shiny session object calls to this function is made without any arguments. If -#' redefining contexts is needed, please use \code{\link{userInfo}} instead. -#' -#' @inheritParams userInfo -#' -#' @return String phone number -#' -#' @seealso \code{\link{getUserName}}, -#' \code{\link{getUserGroups}}, \code{\link{getUserReshId}}, -#' \code{\link{getUserEmail}}, \code{\link{getUserFullName}} -#' -#' @examples -#' \donttest{ -#' # Requires a valid shiny session object -#' try(getUserPhone()) -#' try(getUserPhone(shinySessionObject)) -#' } -#' +#' @rdname userAttribute #' @export - - -getUserPhone <- function(shinySession = NULL) { - userInfo(shinySession, entity = "phone") +getUserPhone <- function(shinySession = NULL, group = NULL) { + userInfo(shinySession, entity = "phone", group = group) } -#' Get user resh ID from config or session object -#' -#' This is a helper function for \code{\link{userInfo}}. When used without a -#' shiny session object calls to this function is made without any arguments. If -#' redefining contexts is needed, please use \code{\link{userInfo}} instead. -#' -#' @inheritParams userInfo -#' -#' @return String user name -#' -#' @seealso \code{\link{getUserName}}, -#' \code{\link{getUserGroups}}, \code{\link{getUserRole}} -#' -#' @examples -#' \donttest{ -#' # Requires a valid shiny session object -#' try(getUserReshId()) -#' try(getUserReshId(shinySessionObject)) -#' } -#' +#' @rdname userAttribute #' @export - - -getUserReshId <- function(shinySession = NULL) { - userInfo(shinySession, entity = "resh_id") +getUserReshId <- function(shinySession = NULL, group = NULL) { + userInfo(shinySession, entity = "resh_id", group = group) } -#' Get user role from config or session object -#' -#' This is a helper function for \code{\link{userInfo}}. When used without a -#' shiny session object calls to this function is made without any arguments. If -#' redefining contexts is needed, please use \code{\link{userInfo}} instead. -#' -#' @inheritParams userInfo -#' -#' @return String user name -#' -#' @seealso \code{\link{getUserName}}, -#' \code{\link{getUserGroups}}, \code{\link{getUserReshId}} -#' -#' @examples -#' \donttest{ -#' # Requires a valid shiny session object -#' try(getUserRole()) -#' try(getUserRole(shinySessionObject)) -#' } -#' +#' @rdname userAttribute #' @export - - -getUserRole <- function(shinySession = NULL) { - userInfo(shinySession, entity = "role") +getUserRole <- function(shinySession = NULL, group = NULL) { + userInfo(shinySession, entity = "role", group = group) } diff --git a/man/getUserEmail.Rd b/man/getUserEmail.Rd deleted file mode 100644 index ebfc8afe..00000000 --- a/man/getUserEmail.Rd +++ /dev/null @@ -1,36 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/userAttribute.R -\name{getUserEmail} -\alias{getUserEmail} -\title{Get user email from config or session object} -\usage{ -getUserEmail(shinySession = NULL) -} -\arguments{ -\item{shinySession}{Shiny session object (list, NULL by default). Must be -provided when the source of user attributes is either the shiny app url or -an external authentication provider. By default this will apply to the -'TEST', 'QA' and 'PRODUCTION' contexts in which case the shiny session -object must be provided.} -} -\value{ -String email address -} -\description{ -This is a helper function for \code{\link{userInfo}}. When used without a -shiny session object calls to this function is made without any arguments. If -redefining contexts is needed, please use \code{\link{userInfo}} instead. -} -\examples{ -\donttest{ -# Requires a valid shiny session object -try(getUserEmail()) -try(getUserEmail(shinySessionObject)) -} - -} -\seealso{ -\code{\link{getUserName}}, -\code{\link{getUserGroups}}, \code{\link{getUserReshId}}, -\code{\link{getUserEmail}} -} diff --git a/man/getUserFullName.Rd b/man/getUserFullName.Rd deleted file mode 100644 index a670fdf6..00000000 --- a/man/getUserFullName.Rd +++ /dev/null @@ -1,36 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/userAttribute.R -\name{getUserFullName} -\alias{getUserFullName} -\title{Get user full name from config or session object} -\usage{ -getUserFullName(shinySession = NULL) -} -\arguments{ -\item{shinySession}{Shiny session object (list, NULL by default). Must be -provided when the source of user attributes is either the shiny app url or -an external authentication provider. By default this will apply to the -'TEST', 'QA' and 'PRODUCTION' contexts in which case the shiny session -object must be provided.} -} -\value{ -String full name -} -\description{ -This is a helper function for \code{\link{userInfo}}. When used without a -shiny session object calls to this function is made without any arguments. If -redefining contexts is needed, please use \code{\link{userInfo}} instead. -} -\examples{ -\donttest{ -# Requires a valid shiny session object -try(getUserFullName()) -try(getUserFullName(shinySessionObject)) -} - -} -\seealso{ -\code{\link{getUserName}}, -\code{\link{getUserGroups}}, \code{\link{getUserReshId}}, -\code{\link{getUserEmail}}, \code{\link{getUserPhone}} -} diff --git a/man/getUserGroups.Rd b/man/getUserGroups.Rd deleted file mode 100644 index 12ebb5a2..00000000 --- a/man/getUserGroups.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/userAttribute.R -\name{getUserGroups} -\alias{getUserGroups} -\title{Get user groups from config or session object} -\usage{ -getUserGroups(shinySession = NULL) -} -\arguments{ -\item{shinySession}{Shiny session object (list, NULL by default). Must be -provided when the source of user attributes is either the shiny app url or -an external authentication provider. By default this will apply to the -'TEST', 'QA' and 'PRODUCTION' contexts in which case the shiny session -object must be provided.} -} -\value{ -String user name -} -\description{ -This is a helper function for \code{\link{userInfo}}. When used without a -shiny session object calls to this function is made without any arguments. If -redefining contexts is needed, please use \code{\link{userInfo}} instead. -} -\examples{ -\donttest{ -# Requires a valid shiny session object -try(getUserGroups()) -try(getUserGroups(shinySessionObject)) -} - -} -\seealso{ -\code{\link{getUserName}}, -\code{\link{getUserReshId}}, \code{\link{getUserRole}} -} diff --git a/man/getUserName.Rd b/man/getUserName.Rd deleted file mode 100644 index 36e376cd..00000000 --- a/man/getUserName.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/userAttribute.R -\name{getUserName} -\alias{getUserName} -\title{Get user name from config or session object} -\usage{ -getUserName(shinySession = NULL) -} -\arguments{ -\item{shinySession}{Shiny session object (list, NULL by default). Must be -provided when the source of user attributes is either the shiny app url or -an external authentication provider. By default this will apply to the -'TEST', 'QA' and 'PRODUCTION' contexts in which case the shiny session -object must be provided.} -} -\value{ -String user name -} -\description{ -This is a helper function for \code{\link{userInfo}}. When used without a -shiny session object calls to this function is made without any arguments. If -redefining contexts is needed, please use \code{\link{userInfo}} instead. -} -\examples{ -\donttest{ -# Requires a valid shiny session object -try(getUserName()) -try(getUserName(shinySessionObject)) -} - -} -\seealso{ -\code{\link{getUserGroups}}, -\code{\link{getUserReshId}}, \code{\link{getUserRole}} -} diff --git a/man/getUserPhone.Rd b/man/getUserPhone.Rd deleted file mode 100644 index 75cb74a4..00000000 --- a/man/getUserPhone.Rd +++ /dev/null @@ -1,36 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/userAttribute.R -\name{getUserPhone} -\alias{getUserPhone} -\title{Get user phone (number) from config or session object} -\usage{ -getUserPhone(shinySession = NULL) -} -\arguments{ -\item{shinySession}{Shiny session object (list, NULL by default). Must be -provided when the source of user attributes is either the shiny app url or -an external authentication provider. By default this will apply to the -'TEST', 'QA' and 'PRODUCTION' contexts in which case the shiny session -object must be provided.} -} -\value{ -String phone number -} -\description{ -This is a helper function for \code{\link{userInfo}}. When used without a -shiny session object calls to this function is made without any arguments. If -redefining contexts is needed, please use \code{\link{userInfo}} instead. -} -\examples{ -\donttest{ -# Requires a valid shiny session object -try(getUserPhone()) -try(getUserPhone(shinySessionObject)) -} - -} -\seealso{ -\code{\link{getUserName}}, -\code{\link{getUserGroups}}, \code{\link{getUserReshId}}, -\code{\link{getUserEmail}}, \code{\link{getUserFullName}} -} diff --git a/man/getUserReshId.Rd b/man/getUserReshId.Rd deleted file mode 100644 index 076e85ed..00000000 --- a/man/getUserReshId.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/userAttribute.R -\name{getUserReshId} -\alias{getUserReshId} -\title{Get user resh ID from config or session object} -\usage{ -getUserReshId(shinySession = NULL) -} -\arguments{ -\item{shinySession}{Shiny session object (list, NULL by default). Must be -provided when the source of user attributes is either the shiny app url or -an external authentication provider. By default this will apply to the -'TEST', 'QA' and 'PRODUCTION' contexts in which case the shiny session -object must be provided.} -} -\value{ -String user name -} -\description{ -This is a helper function for \code{\link{userInfo}}. When used without a -shiny session object calls to this function is made without any arguments. If -redefining contexts is needed, please use \code{\link{userInfo}} instead. -} -\examples{ -\donttest{ -# Requires a valid shiny session object -try(getUserReshId()) -try(getUserReshId(shinySessionObject)) -} - -} -\seealso{ -\code{\link{getUserName}}, -\code{\link{getUserGroups}}, \code{\link{getUserRole}} -} diff --git a/man/getUserRole.Rd b/man/getUserRole.Rd deleted file mode 100644 index b880a4f1..00000000 --- a/man/getUserRole.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/userAttribute.R -\name{getUserRole} -\alias{getUserRole} -\title{Get user role from config or session object} -\usage{ -getUserRole(shinySession = NULL) -} -\arguments{ -\item{shinySession}{Shiny session object (list, NULL by default). Must be -provided when the source of user attributes is either the shiny app url or -an external authentication provider. By default this will apply to the -'TEST', 'QA' and 'PRODUCTION' contexts in which case the shiny session -object must be provided.} -} -\value{ -String user name -} -\description{ -This is a helper function for \code{\link{userInfo}}. When used without a -shiny session object calls to this function is made without any arguments. If -redefining contexts is needed, please use \code{\link{userInfo}} instead. -} -\examples{ -\donttest{ -# Requires a valid shiny session object -try(getUserRole()) -try(getUserRole(shinySessionObject)) -} - -} -\seealso{ -\code{\link{getUserName}}, -\code{\link{getUserGroups}}, \code{\link{getUserReshId}} -} diff --git a/man/navbarWidget.Rd b/man/navbarWidget.Rd index ed1c326d..3fcb369c 100644 --- a/man/navbarWidget.Rd +++ b/man/navbarWidget.Rd @@ -31,10 +31,10 @@ available organizations.} called from. Default value is \code{environmentName(topenv(parent.frame()))}. The value is used to display the current version of the R package representing the registry at -Rapporteket. If this module is called from exported functions in th -registry R package use the default value. If the module is called from -outside the registry environment \code{caller} must be set to the actual -name of the R package.} +Rapporteket. If this module is called from exported functions in the +registry R package the default value should be applied. If the module is +called from outside the registry environment \code{caller} must be set to +the actual name of the R package.} } \value{ Shiny objects, mostly. Helper functions may return other stuff too. diff --git a/man/userAttribute.Rd b/man/userAttribute.Rd new file mode 100644 index 00000000..aec740de --- /dev/null +++ b/man/userAttribute.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/userAttribute.R +\name{userAttribute} +\alias{userAttribute} +\alias{getUserEmail} +\alias{getUserFullName} +\alias{getUserGroups} +\alias{getUserName} +\alias{getUserPhone} +\alias{getUserReshId} +\alias{getUserRole} +\title{Get user attributes} +\usage{ +getUserEmail(shinySession = NULL, group = NULL) + +getUserFullName(shinySession = NULL, group = NULL) + +getUserGroups(shinySession = NULL, group = NULL) + +getUserName(shinySession = NULL, group = NULL) + +getUserPhone(shinySession = NULL, group = NULL) + +getUserReshId(shinySession = NULL, group = NULL) + +getUserRole(shinySession = NULL, group = NULL) +} +\arguments{ +\item{shinySession}{A shiny session object. Default value is NULL} + +\item{group}{Character string providing the name of the app R package name. +The term "group" is used to relate to the environmental variable +SHINYPROXY_USERGROUPS that corresponds to the apps a given user can access. +Default value is NULL but should always be set when shiny app is run as a +shinyproxy container.} +} +\value{ +String with user attribute +} +\description{ +These are helper function for \code{\link{userInfo}}. When used without a +shiny session object calls to these functions is made without any arguments. +If redefining contexts is needed, please use \code{\link{userInfo}} instead. +} +\examples{ +\donttest{ +# Requires a valid shiny session object +try(getUserEmail()) +try(getUserEmail(shinySessionObject)) +} +} diff --git a/man/userInfo.Rd b/man/userInfo.Rd index 1bd50fba..697c92fb 100644 --- a/man/userInfo.Rd +++ b/man/userInfo.Rd @@ -9,7 +9,8 @@ userInfo( shinySession = NULL, devContexts = c("DEV"), testContexts = c("TEST"), - prodContexts = c("QA", "QAC", "PRODUCTION", "PRODUCTIONC") + prodContexts = c("QA", "QAC", "PRODUCTION", "PRODUCTIONC"), + group = NULL ) } \arguments{ @@ -44,6 +45,10 @@ Instances provided cannot overlap instances in any other contexts. By default set to \code{c("QA", "QAC", "PRODUCTION", "PRODUCTIONC")}. Duplication as seen by the "C" suffix will be needed as long as apps in question are to be run on both shiny-server and as standalone containers.} + +\item{group}{Character string providing the name of the app R package name. +The term "group" is used to relate to the environmental variable +SHINYPROXY_USERGROUPS that corresponds to the apps a given user can access.} } \value{ String of single user data element diff --git a/tests/testthat/test-userInfo.R b/tests/testthat/test-userInfo.R index e6f937a6..a369686c 100644 --- a/tests/testthat/test-userInfo.R +++ b/tests/testthat/test-userInfo.R @@ -259,7 +259,7 @@ with_envvar( new = c( "R_RAP_INSTANCE" = "QAC", "SHINYPROXY_USERNAME" = "userc", - "SHINYPROXY_USERGROUPS" = "groupsc", + "SHINYPROXY_USERGROUPS" = "rapbase", "USERORGID" = "2", "USEREMAIL" = "userc@container.no", "USERFULLNAME" = "User Container", @@ -267,13 +267,13 @@ with_envvar( ), code = { test_that("User attribs can be fetched in container instance (QA, PROD)", { - expect_equal(getUserName(shinySession), "userc") - expect_equal(getUserGroups(shinySession), "groupsc") - expect_equal(getUserReshId(shinySession), "102966") - expect_equal(getUserRole(shinySession), "LU") - expect_equal(getUserEmail(shinySession), "userc@container.no") - expect_equal(getUserFullName(shinySession), "User Container") - expect_equal(getUserPhone(shinySession), "+4787654321") + expect_equal(getUserName(shinySession, "rapbase"), "userc") + expect_equal(getUserGroups(shinySession, "rapbase"), "rapbase") + expect_equal(getUserReshId(shinySession, "rapbase"), "102966") + expect_equal(getUserRole(shinySession, "rapbase"), "LU") + expect_equal(getUserEmail(shinySession, "rapbase"), "userc@container.no") + expect_equal(getUserFullName(shinySession, "rapbase"), "User Container") + expect_equal(getUserPhone(shinySession, "rapbase"), "+4787654321") }) } ) From a36c93aab9ac654c25113d5dd8cf3dc7b10953ce Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 3 Oct 2022 15:13:17 +0200 Subject: [PATCH 19/79] bugger --- R/log.R | 24 ++++++++++++++++-------- R/moduleNavbarWidget.R | 2 +- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/R/log.R b/R/log.R index 1f06b066..243e4e2d 100644 --- a/R/log.R +++ b/R/log.R @@ -122,9 +122,14 @@ NULL #' try(appLogger(list())) #' } #' -appLogger <- function(session, msg = "No message provided") { +appLogger <- function(session, msg = "No message provided", + .topcall = sys.call(-1), .topenv = parent.frame()) { name <- "appLog" - content <- c(getSessionData(session), list(message = msg)) + parent_environment <- environmentName(topenv(.topenv)) + content <- c( + getSessionData(session, group = parent_environment), + list(message = msg) + ) event <- makeLogRecord(content) appendLog(event, name) } @@ -270,16 +275,19 @@ makeLogRecord <- function(content) { #' Internal function providing session data relevant to logging. #' #' @param session A shiny session object +#' @param group Character string providing the name of the app R package name. +#' The term "group" is used to relate to the environmental variable +#' SHINYPROXY_USERGROUPS that corresponds to the apps a given user can access. #' #' @return A list of relevant log fields #' @keywords internal -getSessionData <- function(session) { +getSessionData <- function(session, group = NULL) { list( - user = rapbase::getUserName(session), - name = rapbase::getUserFullName(session), - group = rapbase::getUserGroups(session), - role = rapbase::getUserRole(session), - resh_id = rapbase::getUserReshId(session) + user = rapbase::getUserName(session, group), + name = rapbase::getUserFullName(session, group), + group = rapbase::getUserGroups(session, group), + role = rapbase::getUserRole(session, group), + resh_id = rapbase::getUserReshId(session, group) ) } diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index 90bcd391..5f4b09cd 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -87,7 +87,7 @@ navbarWidgetServer <- function( group = NULL, unit = NULL, org = NULL, - role = getUserRole(session), + role = getUserRole(session, caller), name = NULL ) From d2597c179104cbf14ced1d19f59f598d92ebdc0a Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 6 Oct 2022 14:06:25 +0200 Subject: [PATCH 20/79] better use LU as first entry --- data-raw/accesstree.R | 8 ++++---- inst/extdata/accesstree.json | 2 +- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/data-raw/accesstree.R b/data-raw/accesstree.R index c2045884..2d6caf40 100644 --- a/data-raw/accesstree.R +++ b/data-raw/accesstree.R @@ -7,11 +7,11 @@ j <- ' "HasDatabase": true, "ExternalId": 100082, "HealthUnitId": 100082, - "Title": "Helse Bergen HF - SC", + "Title": "Helse Bergen HF - LU", "TitleWithPath": "Helse Bergen HF", "ValidFrom": null, "ValidTo": null, - "ExtraData": "SC" + "ExtraData": "LU" }, { "UnitId": 2, @@ -19,11 +19,11 @@ j <- ' "HasDatabase": true, "ExternalId": 102966, "HealthUnitId": 102966, - "Title": "HB Hjerteavdelingen - LU", + "Title": "HB Hjerteavdelingen - SC", "TitleWithPath": "Helse Bergen HF - HB Hjerteavdelingen", "ValidFrom": null, "ValidTo": null, - "ExtraData": "LU" + "ExtraData": "SC" }, { "UnitId": 3, diff --git a/inst/extdata/accesstree.json b/inst/extdata/accesstree.json index 73cf6adf..d24b4f8f 100644 --- a/inst/extdata/accesstree.json +++ b/inst/extdata/accesstree.json @@ -1 +1 @@ -{"AccessUnits":[{"UnitId":[1],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[100082],"HealthUnitId":[100082],"Title":["Helse Bergen HF - SC"],"TitleWithPath":["Helse Bergen HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[2],"ParentUnitId":[1],"HasDatabase":[true],"ExternalId":[102966],"HealthUnitId":[102966],"Title":["HB Hjerteavdelingen - LU"],"TitleWithPath":["Helse Bergen HF - HB Hjerteavdelingen"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]},{"UnitId":[3],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[4001031],"HealthUnitId":[4001031],"Title":["Oslo universitetssykehus HF - SC"],"TitleWithPath":["Oslo universitetssykehus HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[4],"ParentUnitId":[3],"HasDatabase":[true],"ExternalId":[700328],"HealthUnitId":[700328],"Title":["Hjerte-, lunge- og karklinikken - LU"],"TitleWithPath":["Oslo universitetssykehus HF - Hjerte-, lunge- og karklinikken"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]},{"UnitId":[5],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[100320],"HealthUnitId":[100320],"Title":["St. Olavs Hospital HF - SC"],"TitleWithPath":["St. Olavs Hospital HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[6],"ParentUnitId":[5],"HasDatabase":[true],"ExternalId":[104284],"HealthUnitId":[104284],"Title":["Klinikk for Hjertemedisin - LU"],"TitleWithPath":["St. Olavs Hospital HF - Klinikk for Hjertemedisin"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]},{"UnitId":[7],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[106944],"HealthUnitId":[106944],"Title":["AHUS Gardermoen - SC"],"TitleWithPath":["AHUS Gardermoen"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[8],"ParentUnitId":[7],"HasDatabase":[true],"ExternalId":[4214492],"HealthUnitId":[4214492],"Title":["Hjertemedisinsk avdeling - LU"],"TitleWithPath":["AHUS Gardermoen - Hjertemedisinsk avdeling"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]}]} +{"AccessUnits":[{"UnitId":[1],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[100082],"HealthUnitId":[100082],"Title":["Helse Bergen HF - LU"],"TitleWithPath":["Helse Bergen HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]},{"UnitId":[2],"ParentUnitId":[1],"HasDatabase":[true],"ExternalId":[102966],"HealthUnitId":[102966],"Title":["HB Hjerteavdelingen - SC"],"TitleWithPath":["Helse Bergen HF - HB Hjerteavdelingen"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[3],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[4001031],"HealthUnitId":[4001031],"Title":["Oslo universitetssykehus HF - SC"],"TitleWithPath":["Oslo universitetssykehus HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[4],"ParentUnitId":[3],"HasDatabase":[true],"ExternalId":[700328],"HealthUnitId":[700328],"Title":["Hjerte-, lunge- og karklinikken - LU"],"TitleWithPath":["Oslo universitetssykehus HF - Hjerte-, lunge- og karklinikken"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]},{"UnitId":[5],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[100320],"HealthUnitId":[100320],"Title":["St. Olavs Hospital HF - SC"],"TitleWithPath":["St. Olavs Hospital HF"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[6],"ParentUnitId":[5],"HasDatabase":[true],"ExternalId":[104284],"HealthUnitId":[104284],"Title":["Klinikk for Hjertemedisin - LU"],"TitleWithPath":["St. Olavs Hospital HF - Klinikk for Hjertemedisin"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]},{"UnitId":[7],"ParentUnitId":[0],"HasDatabase":[true],"ExternalId":[106944],"HealthUnitId":[106944],"Title":["AHUS Gardermoen - SC"],"TitleWithPath":["AHUS Gardermoen"],"ValidFrom":{},"ValidTo":{},"ExtraData":["SC"]},{"UnitId":[8],"ParentUnitId":[7],"HasDatabase":[true],"ExternalId":[4214492],"HealthUnitId":[4214492],"Title":["Hjertemedisinsk avdeling - LU"],"TitleWithPath":["AHUS Gardermoen - Hjertemedisinsk avdeling"],"ValidFrom":{},"ValidTo":{},"ExtraData":["LU"]}]} From a492225c8956cecf18921f2a1330e888c9f64043 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 6 Oct 2022 14:07:29 +0200 Subject: [PATCH 21/79] prep for user attribute reactivity --- R/autoReport.R | 46 ++++++++++++++++++++++++++++-------------- R/moduleAutoReport.R | 4 ++++ R/moduleNavbarWidget.R | 4 ++-- 3 files changed, 37 insertions(+), 17 deletions(-) diff --git a/R/autoReport.R b/R/autoReport.R index 768570cc..bfca47b7 100644 --- a/R/autoReport.R +++ b/R/autoReport.R @@ -645,7 +645,7 @@ findNextRunDate <- function(runDayOfYear, #' #' Make a table to be rendered in a shiny app providing automated reports #' from a given user or registry as obtained from the shiny session -#' object provided. +#' object provided or environmental variables when run inside an app container. #' #' Each table record (line) represents a uniquely defined automated report. #' For each line two shiny action buttons are provided to allow @@ -670,26 +670,42 @@ findNextRunDate <- function(runDayOfYear, #' #' @param session A shiny session object #' @param namespace String naming namespace. Defaults to \code{character()} in -#' which case no namespace will be created. When this function is used by shiny -#' modules namespace must be provided. +#' which case no namespace will be created. When this function is used by +#' shiny modules namespace must be provided. +#' @param user Character string providing the username. Introduced as a new +#' argument when running apps inside containers. Default value is set to +#' \code{rapbase::getUserName(session)} to allow backward compatibility. +#' @param group Character string defining the registry, normally corresponding +#' to the R package name and the value stemming from the SHINYPROXY_GROUPS +#' environment variable. Introduced as a new argument when running apps inside +#' containers. Default value is set to \code{rapbase::getUserGroups(session)} +#' to allow backward compatibility. +#' @param orgId Character string or integer defining the organization (id) for +#' \code{user}. Default value is set to \code{rapbase::getUserReshId(session)} +#' to allow backward compatibility. #' @param type Character string defining the type of auto reports to tabulate. -#' Must be one of \code{"subscription"}, \code{"dispatchment"} or -#' \code{"bulletin"}. Default value set to \code{"subscription"}. +#' Must be one of \code{"subscription"}, \code{"dispatchment"} or +#' \code{"bulletin"}. Default value set to \code{"subscription"}. #' @param mapOrgId Data frame containing the two columns 'name' and 'id' -#' corresponding to unique name and id of organizations. Default is NULL in -#' which case the ids provided in auto report data will be used. In case -#' mapOrgId is not NULL but no id match is found the id found in the auto -#' report data will also be used +#' corresponding to unique name and id of organizations. Default is NULL in +#' which case the ids provided in auto report data will be used. In case +#' mapOrgId is not NULL but no id match is found the id found in the auto +#' report data will also be used #' @param includeReportId Logical if the unique report id should be added as -#' the last column in the table. FALSE by default. +#' the last column in the table. FALSE by default. #' #' @return Matrix providing a table to be rendered in a shiny app #' @importFrom magrittr "%>%" #' @export # nolint end -makeAutoReportTab <- function(session, namespace = character(), - type = "subscription", mapOrgId = NULL, +makeAutoReportTab <- function(session, + namespace = character(), + user = rapbase::getUserName(session), + group = rapbase::getUserGroups(session), + orgId = rapbase::getUserReshId(session), + type = "subscription", + mapOrgId = NULL, includeReportId = FALSE) { stopifnot(type %in% c("subscription", "dispatchment", "bulletin")) @@ -697,13 +713,13 @@ makeAutoReportTab <- function(session, namespace = character(), l <- list() autoRep <- readAutoReportData() %>% - filterAutoRep(., by = "package", pass = getUserGroups(session)) %>% + filterAutoRep(., by = "package", pass = group) %>% filterAutoRep(., by = "type", pass = type) if (type == "subscription") { autoRep <- autoRep %>% - filterAutoRep(., by = "owner", pass = getUserName(session)) %>% - filterAutoRep(., by = "organization", pass = getUserReshId(session)) + filterAutoRep(., by = "owner", pass = user) %>% + filterAutoRep(., by = "organization", pass = orgId) } dateFormat <- "%A %e. %B %Y" diff --git a/R/moduleAutoReport.R b/R/moduleAutoReport.R index 452deca4..3e340d11 100644 --- a/R/moduleAutoReport.R +++ b/R/moduleAutoReport.R @@ -247,6 +247,7 @@ autoReportServer <- function(id, registryName, type, org = NULL, tab = makeAutoReportTab( session = session, namespace = id, + group = registryName, type = type, mapOrgId = orgList2df(orgs) ), @@ -307,6 +308,7 @@ autoReportServer <- function(id, registryName, type, org = NULL, makeAutoReportTab( session, namespace = id, + group = registryName, type = type, mapOrgId = orgList2df(orgs) ) @@ -330,6 +332,7 @@ autoReportServer <- function(id, registryName, type, org = NULL, autoReport$tab <- makeAutoReportTab( session, namespace = id, + group = registryName, type = type, mapOrgId = orgList2df(orgs) ) @@ -351,6 +354,7 @@ autoReportServer <- function(id, registryName, type, org = NULL, autoReport$tab <- makeAutoReportTab( session, namespace = id, + group = registryName, type = type, mapOrgId = orgList2df(orgs) ) diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index 5f4b09cd..4b06926f 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -84,9 +84,9 @@ navbarWidgetServer <- function( # to be populated further if and when inside an app container rv <- shiny::reactiveValues( - group = NULL, + group = caller, unit = NULL, - org = NULL, + org = getUserReshId(session, caller), role = getUserRole(session, caller), name = NULL ) From a13b72880996e4b14e539a4401e1c261afa8079f Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 6 Oct 2022 14:51:21 +0200 Subject: [PATCH 22/79] add user name, for the convenience of it --- R/userAttribute.R | 15 +++++++++++++-- man/getContainerPrivileges.Rd | 10 +++++++++- 2 files changed, 22 insertions(+), 3 deletions(-) diff --git a/R/userAttribute.R b/R/userAttribute.R index 724e74f4..d883f636 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -182,7 +182,15 @@ userInfo <- function( #' @param unit Integer providing the look-up unit id. Default value is NULL in #' which case all privileges for \code{group} are returned. #' -#' @return List of privileges +#' @return List of privileges: +#' \describe{ +#' \item{user}{The username for whom the privileges apply.} +#' \item{group}{Group of which the user is a member.} +#' \item{unit}{Unit id under which the privileges are defined.} +#' \item{org}{Organization id for the user.} +#' \item{role}{Role of the user.} +#' \item{orgName}{Name of the organization as defined under the unit id.} +#' } #' @export getContainerPrivileges <- function(group, unit = NULL) { @@ -197,6 +205,8 @@ getContainerPrivileges <- function(group, unit = NULL) { )) } + user <- Sys.getenv("SHINYPROXY_USERNAME") + # make vectors of vals units <- unlist( strsplit( @@ -241,11 +251,12 @@ getContainerPrivileges <- function(group, unit = NULL) { } list( + user = rep(user, length(units)), group = groups, unit = units, org = org, role = role, - name = name + orgName = name ) } diff --git a/man/getContainerPrivileges.Rd b/man/getContainerPrivileges.Rd index de295be8..19283778 100644 --- a/man/getContainerPrivileges.Rd +++ b/man/getContainerPrivileges.Rd @@ -15,7 +15,15 @@ SHINYPROXY_USERGROUPS that corresponds to the apps a given user can access.} which case all privileges for \code{group} are returned.} } \value{ -List of privileges +List of privileges: + \describe{ + \item{user}{The username for whom the privileges apply.} + \item{group}{Group of which the user is a member.} + \item{unit}{Unit id under which the privileges are defined.} + \item{org}{Organization id for the user.} + \item{role}{Role of the user.} + \item{orgName}{Name of the organization as defined under the unit id.} + } } \description{ For apps running as containers particular environment variables must be From c33153dd0f808e7250ccb9b1d83dc850166e362a Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 6 Oct 2022 15:39:51 +0200 Subject: [PATCH 23/79] reactives for auto reps, still under construction --- R/moduleAutoReport.R | 101 +++++++++++++++++++++------------ R/moduleNavbarWidget.R | 4 +- man/autoReport.Rd | 46 ++++++++++----- man/getSessionData.Rd | 6 +- man/logger.Rd | 7 ++- man/makeAutoReportTab.Rd | 23 +++++++- tests/testthat/test-userInfo.R | 4 +- 7 files changed, 133 insertions(+), 58 deletions(-) diff --git a/R/moduleAutoReport.R b/R/moduleAutoReport.R index 3e340d11..58e05b69 100644 --- a/R/moduleAutoReport.R +++ b/R/moduleAutoReport.R @@ -26,40 +26,52 @@ #' #' @param id Character string providing the shiny module id. #' @param registryName Character string with the registry name key. Must -#' correspond to the registry R package name. +#' correspond to the registry R package name. #' @param type Character string defining the type of auto reports. Must be one -#' of \code{c("subscription", "dispatchment", "bulletin")} +#' of \code{c("subscription", "dispatchment", "bulletin")} #' @param reports List of a given structure that provides meta data for the -#' reports that are made available as automated reports. See Details for further -#' description. +#' reports that are made available as automated reports. See Details for +#' further description. #' @param org Shiny reactive or NULL (default) defining the organization (id) -#' of the data source used for dispatchments and bulletins (in which case it -#' cannot be set to NULL) and its value will be used to populate the -#' \emph{organization} field in auto report data (autoReport.yml) for these auto -#' report types. On the other hand, since subscriptions are personal (per user) -#' the only relevant organization id will implicit be that of the user and in -#' this case any value of \code{org} will be disregarded. +#' of the data source used for dispatchments and bulletins (in which case it +#' cannot be set to NULL) and its value will be used to populate the +#' \emph{organization} field in auto report data (autoReport.yml) for these +#' auto report types. On the other hand, since subscriptions are personal +#' (per user) the only relevant organization id will implicit be that of the +#' user and in this case any value of \code{org} will be disregarded. #' @param paramNames Shiny reactive value as a vector of parameter names of -#' which values are to be set interactively at application run time. Each -#' element of this vector must match exactly those of \code{paramValues}. -#' Default value is \code{shiny::reactiveVal("")}. +#' which values are to be set interactively at application run time. Each +#' element of this vector must match exactly those of \code{paramValues}. +#' Default value is \code{shiny::reactiveVal("")}. #' @param paramValues Shiny reactive value as a vector of those parameter values -#' to be set interactively, \emph{i.e.} as per user input in the application. -#' Default value is set to \code{shiny::reactiveVal("")} in which case parameter -#' values defined in \code{reports} will be used as is. In other words, -#' explicit use of \code{paramValues} will only be needed if parameter values -#' must be changed during application run time. If so, each element of this -#' vector must correspond exactly to those of \code{paramNames}. +#' to be set interactively, \emph{i.e.} as per user input in the application. +#' Default value is set to \code{shiny::reactiveVal("")} in which case +#' parameter values defined in \code{reports} will be used as is. In other +#' words, explicit use of \code{paramValues} will only be needed if parameter +#' values must be changed during application run time. If so, each element of +#' this vector must correspond exactly to those of \code{paramNames}. #' @param orgs Named list of organizations (names) and ids (values). When set to -#' \code{NULL} (default) the ids found in auto report data will be used in the -#' table listing existing auto reports. +#' \code{NULL} (default) the ids found in auto report data will be used in the +#' table listing existing auto reports. #' @param eligible Logical defining if the module should be allowed to work at -#' full capacity. This might be useful when access to module products should be -#' restricted. Default is TRUE, \emph{i.e.} no restrictions. +#' full capacity. This might be useful when access to module products should +#' be restricted. Default is TRUE, \emph{i.e.} no restrictions. #' @param freq Character string defining default frequency set in the auto -#' report GUI. Must be one of -#' \code{c("day", "week", "month", "quarter", "year")}. Default value is -#' "month". +#' report GUI. Must be one of +#' \code{c("day", "week", "month", "quarter", "year")}. Default value is +#' "month". +#' @param userName Shiny reactive value character string providing user name. +#' Default value set to \code{shiny::reactiveVal(getUserName(session))}. For +#' applications run under shinyproxy this value must be explicitly defined, +#' see \code{\link{navbarWidgetServer}}. +#' @param userOrg Shiny reactive value character string providing user org id. +#' Default value set to \code{shiny::reactiveVal(getUserReshId(session))}. For +#' applications run under shinyproxy this value must be explicitly defined, +#' see \code{\link{navbarWidgetServer}}. +#' @param userRole Shiny reactive value character string providing user role. +#' Default value set to \code{shiny::reactiveVal(getUserRole(session))}. For +#' applications run under shinyproxy this value must be explicitly defined, +#' see \code{\link{navbarWidgetServer}}. #' #' #' @return In general, shiny objects. In particular, \code{autoreportOrgServer} @@ -70,8 +82,8 @@ #' "id". #' @name autoReport #' @aliases autoReportUI autoReportOrgInput autoReportOrgServer -#' autoReportFormatInput autoReportFormatSercer autoReportInput autoReportServer -#' autoReportApp orgList2df +#' autoReportFormatInput autoReportFormatSercer autoReportInput +#' autoReportServer autoReportApp orgList2df #' @examples #' ## make a list for report metadata #' reports <- list( @@ -221,17 +233,28 @@ autoReportInput <- function(id) { #' @rdname autoReport #' @export -autoReportServer <- function(id, registryName, type, org = NULL, - paramNames = shiny::reactiveVal(c("")), - paramValues = shiny::reactiveVal(c("")), - reports = NULL, orgs = NULL, eligible = TRUE, - freq = "month") { +autoReportServer <- function( + id, + registryName, + type, + org = NULL, + paramNames = shiny::reactiveVal(c("")), + paramValues = shiny::reactiveVal(c("")), + reports = NULL, + orgs = NULL, + eligible = TRUE, + freq = "month", + userName = shiny::reactiveVal(""), + userOrg = shiny::reactiveVal(""), + userRole = shiny::reactiveVal("") +) { if (!type %in% c("subscription")) { stopifnot(shiny::is.reactive(org)) stopifnot(shiny::is.reactive(paramNames)) stopifnot(shiny::is.reactive(paramValues)) } - + stopifnot(shiny::is.reactive(userOrg)) + stopifnot(shiny::is.reactive(userRole)) stopifnot(freq %in% c("day", "week", "month", "quarter", "year")) defaultFreq <- switch(freq, @@ -273,7 +296,7 @@ autoReportServer <- function(id, registryName, type, org = NULL, if (type %in% c("subscription") | is.null(orgs)) { email <- getUserEmail(session) - organization <- getUserReshId(session) + organization <- userOrg() } else { organization <- org() if (!paramValues()[1] == "") { @@ -292,7 +315,7 @@ autoReportServer <- function(id, registryName, type, org = NULL, fun = report$fun, paramNames = report$paramNames, paramValues = paramValues, - owner = rapbase::getUserName(session), + owner = userName(), ownerName = rapbase::getUserFullName(session), email = email, organization = organization, @@ -308,7 +331,9 @@ autoReportServer <- function(id, registryName, type, org = NULL, makeAutoReportTab( session, namespace = id, + user = userName(), group = registryName, + orgId = userOrg(), type = type, mapOrgId = orgList2df(orgs) ) @@ -332,7 +357,9 @@ autoReportServer <- function(id, registryName, type, org = NULL, autoReport$tab <- makeAutoReportTab( session, namespace = id, + user = userName(), group = registryName, + orgId = userOrg(), type = type, mapOrgId = orgList2df(orgs) ) @@ -354,7 +381,9 @@ autoReportServer <- function(id, registryName, type, org = NULL, autoReport$tab <- makeAutoReportTab( session, namespace = id, + user = userName(), group = registryName, + orgId = userOrg(), type = type, mapOrgId = orgList2df(orgs) ) diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index 4b06926f..157dacc8 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -147,15 +147,17 @@ navbarWidgetServer <- function( ## Start MOVE OUTSIDE observer when we are all containers ------------- ## privs <- getContainerPrivileges(caller) ## End MOVE OUTSIDE --------------------------------------------------- ## + rv$user <- privs$user[privs$unit == input$unit] rv$group <- privs$group[privs$unit == input$unit] rv$unit <- privs$unit[privs$unit == input$unit] rv$org <- privs$org[privs$unit == input$unit] rv$role <- privs$role[privs$unit == input$unit] - rv$name <- privs$name[privs$unit == input$unit] + rv$orgName <- privs$orgName[privs$unit == input$unit] }) invisible( list( + user = shiny::reactive(rv$user), group = shiny::reactive(rv$group), unit = shiny::reactive(rv$unit), org = shiny::reactive(rv$org), diff --git a/man/autoReport.Rd b/man/autoReport.Rd index 55dbd570..118b2f91 100644 --- a/man/autoReport.Rd +++ b/man/autoReport.Rd @@ -36,7 +36,10 @@ autoReportServer( reports = NULL, orgs = NULL, eligible = TRUE, - freq = "month" + freq = "month", + userName = shiny::reactiveVal(getUserName(session)), + userOrg = shiny::reactiveVal(getUserReshId(session)), + userRole = shiny::reactiveVal(getUserRole(session)) ) autoReportApp( @@ -65,10 +68,10 @@ of \code{c("subscription", "dispatchment", "bulletin")}} \item{org}{Shiny reactive or NULL (default) defining the organization (id) of the data source used for dispatchments and bulletins (in which case it cannot be set to NULL) and its value will be used to populate the -\emph{organization} field in auto report data (autoReport.yml) for these auto -report types. On the other hand, since subscriptions are personal (per user) -the only relevant organization id will implicit be that of the user and in -this case any value of \code{org} will be disregarded.} +\emph{organization} field in auto report data (autoReport.yml) for these +auto report types. On the other hand, since subscriptions are personal +(per user) the only relevant organization id will implicit be that of the +user and in this case any value of \code{org} will be disregarded.} \item{paramNames}{Shiny reactive value as a vector of parameter names of which values are to be set interactively at application run time. Each @@ -77,24 +80,39 @@ Default value is \code{shiny::reactiveVal("")}.} \item{paramValues}{Shiny reactive value as a vector of those parameter values to be set interactively, \emph{i.e.} as per user input in the application. -Default value is set to \code{shiny::reactiveVal("")} in which case parameter -values defined in \code{reports} will be used as is. In other words, -explicit use of \code{paramValues} will only be needed if parameter values -must be changed during application run time. If so, each element of this -vector must correspond exactly to those of \code{paramNames}.} +Default value is set to \code{shiny::reactiveVal("")} in which case +parameter values defined in \code{reports} will be used as is. In other +words, explicit use of \code{paramValues} will only be needed if parameter +values must be changed during application run time. If so, each element of +this vector must correspond exactly to those of \code{paramNames}.} \item{reports}{List of a given structure that provides meta data for the -reports that are made available as automated reports. See Details for further -description.} +reports that are made available as automated reports. See Details for +further description.} \item{eligible}{Logical defining if the module should be allowed to work at -full capacity. This might be useful when access to module products should be -restricted. Default is TRUE, \emph{i.e.} no restrictions.} +full capacity. This might be useful when access to module products should +be restricted. Default is TRUE, \emph{i.e.} no restrictions.} \item{freq}{Character string defining default frequency set in the auto report GUI. Must be one of \code{c("day", "week", "month", "quarter", "year")}. Default value is "month".} + +\item{userName}{Shiny reactive value character string providing user name. +Default value set to \code{shiny::reactiveVal(getUserName(session))}. For +applications run under shinyproxy this value must be explicitly defined, +see \code{\link{navbarWidgetServer}}.} + +\item{userOrg}{Shiny reactive value character string providing user org id. +Default value set to \code{shiny::reactiveVal(getUserReshId(session))}. For +applications run under shinyproxy this value must be explicitly defined, +see \code{\link{navbarWidgetServer}}.} + +\item{userRole}{Shiny reactive value character string providing user role. +Default value set to \code{shiny::reactiveVal(getUserRole(session))}. For +applications run under shinyproxy this value must be explicitly defined, +see \code{\link{navbarWidgetServer}}.} } \value{ In general, shiny objects. In particular, \code{autoreportOrgServer} diff --git a/man/getSessionData.Rd b/man/getSessionData.Rd index fed118c2..3e8061e6 100644 --- a/man/getSessionData.Rd +++ b/man/getSessionData.Rd @@ -4,10 +4,14 @@ \alias{getSessionData} \title{Get session data} \usage{ -getSessionData(session) +getSessionData(session, group = NULL) } \arguments{ \item{session}{A shiny session object} + +\item{group}{Character string providing the name of the app R package name. +The term "group" is used to relate to the environmental variable +SHINYPROXY_USERGROUPS that corresponds to the apps a given user can access.} } \value{ A list of relevant log fields diff --git a/man/logger.Rd b/man/logger.Rd index 167e9bbc..1761fe77 100644 --- a/man/logger.Rd +++ b/man/logger.Rd @@ -7,7 +7,12 @@ \alias{autLogger} \title{Log user events in shiny applications at Rapporteket} \usage{ -appLogger(session, msg = "No message provided") +appLogger( + session, + msg = "No message provided", + .topcall = sys.call(-1), + .topenv = parent.frame() +) repLogger( session, diff --git a/man/makeAutoReportTab.Rd b/man/makeAutoReportTab.Rd index e3cf4160..45ca4b70 100644 --- a/man/makeAutoReportTab.Rd +++ b/man/makeAutoReportTab.Rd @@ -7,6 +7,9 @@ makeAutoReportTab( session, namespace = character(), + user = rapbase::getUserName(session), + group = rapbase::getUserGroups(session), + orgId = rapbase::getUserReshId(session), type = "subscription", mapOrgId = NULL, includeReportId = FALSE @@ -16,8 +19,22 @@ makeAutoReportTab( \item{session}{A shiny session object} \item{namespace}{String naming namespace. Defaults to \code{character()} in -which case no namespace will be created. When this function is used by shiny -modules namespace must be provided.} +which case no namespace will be created. When this function is used by +shiny modules namespace must be provided.} + +\item{user}{Character string providing the username. Introduced as a new +argument when running apps inside containers. Default value is set to +\code{rapbase::getUserName(session)} to allow backward compatibility.} + +\item{group}{Character string defining the registry, normally corresponding +to the R package name and the value stemming from the SHINYPROXY_GROUPS +environment variable. Introduced as a new argument when running apps inside +containers. Default value is set to \code{rapbase::getUserGroups(session)} +to allow backward compatibility.} + +\item{orgId}{Character string or integer defining the organization (id) for +\code{user}. Default value is set to \code{rapbase::getUserReshId(session)} +to allow backward compatibility.} \item{type}{Character string defining the type of auto reports to tabulate. Must be one of \code{"subscription"}, \code{"dispatchment"} or @@ -38,7 +55,7 @@ Matrix providing a table to be rendered in a shiny app \description{ Make a table to be rendered in a shiny app providing automated reports from a given user or registry as obtained from the shiny session -object provided. +object provided or environmental variables when run inside an app container. } \details{ Each table record (line) represents a uniquely defined automated report. diff --git a/tests/testthat/test-userInfo.R b/tests/testthat/test-userInfo.R index a369686c..5987662c 100644 --- a/tests/testthat/test-userInfo.R +++ b/tests/testthat/test-userInfo.R @@ -252,7 +252,7 @@ test_that("warning is given when unit does not exist", { }) test_that("unit attributes can be obtained", { - expect_equal(unitAttribute(2, "role"), "LU") + expect_equal(unitAttribute(2, "role"), "SC") }) with_envvar( @@ -270,7 +270,7 @@ with_envvar( expect_equal(getUserName(shinySession, "rapbase"), "userc") expect_equal(getUserGroups(shinySession, "rapbase"), "rapbase") expect_equal(getUserReshId(shinySession, "rapbase"), "102966") - expect_equal(getUserRole(shinySession, "rapbase"), "LU") + expect_equal(getUserRole(shinySession, "rapbase"), "SC") expect_equal(getUserEmail(shinySession, "rapbase"), "userc@container.no") expect_equal(getUserFullName(shinySession, "rapbase"), "User Container") expect_equal(getUserPhone(shinySession, "rapbase"), "+4787654321") From 7e948fd9eb572d13577741bad9b2776d54571e5f Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 7 Oct 2022 15:38:15 +0200 Subject: [PATCH 24/79] still under construction --- NAMESPACE | 4 +- R/moduleAutoReport.R | 84 ++++++++++++++++++++++------------ R/moduleNavbarWidget.R | 44 ++++++++++++------ R/userAttribute.R | 58 +++++++++++++---------- man/autoReport.Rd | 20 ++++---- man/getContainerPrivileges.Rd | 33 ------------- man/navbarWidget.Rd | 6 ++- man/userAttribute.Rd | 29 ++++++++++-- tests/testthat/test-userInfo.R | 42 +++++++++-------- 9 files changed, 184 insertions(+), 136 deletions(-) delete mode 100644 man/getContainerPrivileges.Rd diff --git a/NAMESPACE b/NAMESPACE index 1789c571..c4035473 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,7 +13,7 @@ export(autoReportFormatServer) export(autoReportInput) export(autoReportOrgInput) export(autoReportOrgServer) -export(autoReportServer) +export(autoReportServer2) export(autoReportUI) export(cleanStagingData) export(createAutoReport) @@ -31,7 +31,6 @@ export(filterAutoRep) export(findNextRunDate) export(fireInTheHole) export(getConfig) -export(getContainerPrivileges) export(getGithub) export(getRapPackages) export(getRegs) @@ -81,6 +80,7 @@ export(statsServer) export(statsUI) export(unitAttribute) export(upgradeAutoReportData) +export(userAttribute) export(userInfo) export(writeAutoReportData) importFrom(magrittr,"%>%") diff --git a/R/moduleAutoReport.R b/R/moduleAutoReport.R index 58e05b69..3c919894 100644 --- a/R/moduleAutoReport.R +++ b/R/moduleAutoReport.R @@ -19,10 +19,10 @@ #' schedule and must therefore represent existing and exported functions from #' the registry R package. For subscriptions the \emph{reports} list can be used #' as is, more specifically that the values provided in \emph{paramValues} can -#' go unchanged. For dispatchments and bulletins it is likely that parameter -#' values must be set dynamically in which case \emph{paramValues} must be -#' a reactive part of the application. See Examples on how function arguments -#' may be used as reactives in an application. +#' go unchanged. It is likely that parameter values must be set dynamically at +#' runtime in which case \emph{paramValues} must be a reactive part of the +#' application. See Examples on how function arguments may be used as reactives +#' in an application. #' #' @param id Character string providing the shiny module id. #' @param registryName Character string with the registry name key. Must @@ -72,6 +72,10 @@ #' Default value set to \code{shiny::reactiveVal(getUserRole(session))}. For #' applications run under shinyproxy this value must be explicitly defined, #' see \code{\link{navbarWidgetServer}}. +#' @param userEmail Shiny reactive value character string providing user email. +#' Default value set to \code{shiny::reactiveVal(getUserEmail(session))}. For +#' applications run under shinyproxy this value must be explicitly defined, +#' see \code{\link{navbarWidgetServer}}. #' #' #' @return In general, shiny objects. In particular, \code{autoreportOrgServer} @@ -233,7 +237,7 @@ autoReportInput <- function(id) { #' @rdname autoReport #' @export -autoReportServer <- function( +autoReportServer2 <- function( id, registryName, type, @@ -244,17 +248,16 @@ autoReportServer <- function( orgs = NULL, eligible = TRUE, freq = "month", - userName = shiny::reactiveVal(""), - userOrg = shiny::reactiveVal(""), - userRole = shiny::reactiveVal("") + user ) { + stopifnot( + all(unlist(lapply(user, shiny::is.reactive), use.names = FALSE)) + ) if (!type %in% c("subscription")) { stopifnot(shiny::is.reactive(org)) stopifnot(shiny::is.reactive(paramNames)) stopifnot(shiny::is.reactive(paramValues)) } - stopifnot(shiny::is.reactive(userOrg)) - stopifnot(shiny::is.reactive(userRole)) stopifnot(freq %in% c("day", "week", "month", "quarter", "year")) defaultFreq <- switch(freq, @@ -270,7 +273,9 @@ autoReportServer <- function( tab = makeAutoReportTab( session = session, namespace = id, + user = user$name(), group = registryName, + orgId = user$org(), type = type, mapOrgId = orgList2df(orgs) ), @@ -294,19 +299,21 @@ autoReportServer <- function( paramValues <- report$paramValues paramNames <- report$paramNames - if (type %in% c("subscription") | is.null(orgs)) { - email <- getUserEmail(session) - organization <- userOrg() + if (type %in% c("subscription") || is.null(orgs)) { + email <- user$email() + organization <- user$org() } else { organization <- org() - if (!paramValues()[1] == "") { - stopifnot(length(paramNames()) == length(paramValues())) - for (i in seq_len(length(paramNames()))) { - paramValues[paramNames == paramNames()[i]] <- paramValues()[i] - } - } email <- autoReport$email } + if (!paramValues()[1] == "") { + print(paste("paramName:", paramNames())) + print(paste("paramValue:", paramValues())) + stopifnot(length(paramNames()) == length(paramValues())) + for (i in seq_len(length(paramNames()))) { + paramValues[paramNames == paramNames()[i]] <- paramValues()[i] + } + } createAutoReport( synopsis = report$synopsis, @@ -315,8 +322,8 @@ autoReportServer <- function( fun = report$fun, paramNames = report$paramNames, paramValues = paramValues, - owner = userName(), - ownerName = rapbase::getUserFullName(session), + owner = user$name(), + ownerName = user$fullName(), email = email, organization = organization, runDayOfYear = makeRunDayOfYearSequence( @@ -331,9 +338,9 @@ autoReportServer <- function( makeAutoReportTab( session, namespace = id, - user = userName(), + user = user$name(), group = registryName, - orgId = userOrg(), + orgId = user$org(), type = type, mapOrgId = orgList2df(orgs) ) @@ -357,9 +364,9 @@ autoReportServer <- function( autoReport$tab <- makeAutoReportTab( session, namespace = id, - user = userName(), + user = user$name(), group = registryName, - orgId = userOrg(), + orgId = user$org(), type = type, mapOrgId = orgList2df(orgs) ) @@ -381,9 +388,9 @@ autoReportServer <- function( autoReport$tab <- makeAutoReportTab( session, namespace = id, - user = userName(), + user = user$name(), group = registryName, - orgId = userOrg(), + orgId = user$org(), type = type, mapOrgId = orgList2df(orgs) ) @@ -533,7 +540,16 @@ autoReportServer <- function( }) output$activeReports <- DT::renderDataTable( - autoReport$tab, + #autoReport$tab, + makeAutoReportTab( + session, + namespace = id, + user = user$name(), + group = registryName, + orgId = user$org(), + type = type, + mapOrgId = orgList2df(orgs) + ), server = FALSE, escape = FALSE, selection = "none", rownames = FALSE, options = list( @@ -554,7 +570,17 @@ autoReportServer <- function( shiny::p("Ved sp\u00F8rsm\u00E5l ta gjerne kontakt med registeret."), shiny::hr() ) - } else if (length(autoReport$tab) == 0) { + } else if (length( + makeAutoReportTab( + session, + namespace = id, + user = user$name(), + group = registryName, + orgId = user$org(), + type = type, + mapOrgId = orgList2df(orgs) + ) + ) == 0) { shiny::tagList( shiny::h2("Det finnes ingen oppf\u00F8ringer"), shiny::p(paste( diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index 157dacc8..e5b7840f 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -11,7 +11,7 @@ #' @param id Character string providing module namespace #' @param addUserInfo Logical defining if an "about" hyperlink is to be added #' @param selectOrganization Logical providing option for selecting among -#' available organizations. +#' available organizations and roles. #' @param orgName Character string naming the organization #' @param caller Character string naming the environment this function was #' called from. Default value is @@ -22,7 +22,9 @@ #' called from outside the registry environment \code{caller} must be set to #' the actual name of the R package. #' -#' @return Shiny objects, mostly. Helper functions may return other stuff too. +#' @return Shiny objects, mostly. \code{navbarWidgetServer()} invisibly returns +#' a list of reactive values representing user metadata and privileges. See +#' \code{\link{userAttribute}} for further details on these values. #' @name navbarWidget #' @aliases navbarWidgetInput navbarWidgetServer navbarWidgetApp #' @examples @@ -84,14 +86,18 @@ navbarWidgetServer <- function( # to be populated further if and when inside an app container rv <- shiny::reactiveValues( + name = getUserName(session, caller), + fullName = getUserFullName(session, caller), + phone = NULL, + email = NULL, group = caller, unit = NULL, org = getUserReshId(session, caller), role = getUserRole(session, caller), - name = NULL + orgName = NULL ) - output$name <- shiny::renderText(rapbase::getUserFullName(session)) + output$name <- shiny::renderText(rv$fullName) output$affiliation <- shiny::renderText(paste(orgName, rv$role, sep = ", ")) # User info in widget @@ -112,10 +118,12 @@ navbarWidgetServer <- function( shiny::observeEvent(input$selectOrganization, { ## Start MOVE OUTSIDE observer when we are all containers ------------- ## - privs <- getContainerPrivileges(caller) - choices <- privs$unit - names(choices) <- paste0(privs$name, " (", privs$org, ") - ", privs$role) + privs <- userAttribute(caller) ## End MOVE OUTSIDE --------------------------------------------------- ## + choices <- privs$unit + names(choices) <- paste0( + privs$orgName, " (", privs$org, ") - ", privs$role + ) shinyalert::shinyalert( html = TRUE, @@ -133,7 +141,8 @@ navbarWidgetServer <- function( shiny::selectInput( session$ns("unit"), "", - choices + choices, + selected = rv$unit ) )), type = "", imageUrl = "rap/logo.svg", @@ -145,9 +154,13 @@ navbarWidgetServer <- function( shiny::observeEvent(input$unit, { ## Start MOVE OUTSIDE observer when we are all containers ------------- ## - privs <- getContainerPrivileges(caller) + privs <- userAttribute(caller) ## End MOVE OUTSIDE --------------------------------------------------- ## - rv$user <- privs$user[privs$unit == input$unit] + + rv$name <- privs$name[privs$unit == input$unit] + rv$fullName <- privs$fullName[privs$unit == input$unit] + rv$phone <- privs$phone[privs$unit == input$unit] + rv$email <- privs$email[privs$unit == input$unit] rv$group <- privs$group[privs$unit == input$unit] rv$unit <- privs$unit[privs$unit == input$unit] rv$org <- privs$org[privs$unit == input$unit] @@ -157,12 +170,15 @@ navbarWidgetServer <- function( invisible( list( - user = shiny::reactive(rv$user), + name = shiny::reactive(rv$name), + fullName = shiny::reactive(rv$fullName), + phone = shiny::reactive(rv$phone), + email = shiny::reactive(rv$email), group = shiny::reactive(rv$group), unit = shiny::reactive(rv$unit), org = shiny::reactive(rv$org), role = shiny::reactive(rv$role), - name = shiny::reactive(rv$name) + orgName = shiny::reactive(rv$orgName) ) ) }) @@ -179,8 +195,8 @@ navbarWidgetApp <- function(orgName = "Org Name") { shiny::mainPanel( navbarWidgetInput( "testWidget", - addUserInfo = FALSE, - selectOrganization = TRUE + addUserInfo = TRUE, + selectOrganization = FALSE ) ) ) diff --git a/R/userAttribute.R b/R/userAttribute.R index d883f636..51949e9d 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -143,17 +143,16 @@ userInfo <- function( } if (context %in% c("QAC", "PRODUCTIONC")) { - user <- Sys.getenv("SHINYPROXY_USERNAME") - email <- Sys.getenv("USEREMAIL") - full_name <- - parse(text = paste0("'", Sys.getenv("USERFULLNAME"), "'"))[[1]] - phone <- Sys.getenv("USERPHONE") + userprivs <- userAttribute(group) # pick the first of available user privileges - privs <- getContainerPrivileges(group) - privs <- as.data.frame(privs)[1, ] - groups <- privs$group - resh_id <- privs$org - role <- privs$role + userprivs <- as.data.frame(userprivs)[1, ] + user <- userprivs$name + groups <- userprivs$group + resh_id <- userprivs$org + role <- userprivs$role + email <- userprivs$email + full_name <- userprivs$fullName + phone <- userprivs$phone } } @@ -182,9 +181,12 @@ userInfo <- function( #' @param unit Integer providing the look-up unit id. Default value is NULL in #' which case all privileges for \code{group} are returned. #' -#' @return List of privileges: +#' @return Invisibly a list of user metadata and privileges: #' \describe{ -#' \item{user}{The username for whom the privileges apply.} +#' \item{name}{The username for whom the privileges apply.} +#' \item{fullName}{User full name} +#' \item{phone}{User phone number} +#' \item{email}{User email} #' \item{group}{Group of which the user is a member.} #' \item{unit}{Unit id under which the privileges are defined.} #' \item{org}{Organization id for the user.} @@ -193,7 +195,7 @@ userInfo <- function( #' } #' @export -getContainerPrivileges <- function(group, unit = NULL) { +userAttribute <- function(group, unit = NULL) { stopifnot(group %in% utils::installed.packages()[, 1]) @@ -205,7 +207,10 @@ getContainerPrivileges <- function(group, unit = NULL) { )) } - user <- Sys.getenv("SHINYPROXY_USERNAME") + name <- Sys.getenv("SHINYPROXY_USERNAME") + fullName <- parse(text = paste0("'", Sys.getenv("USERFULLNAME"), "'"))[[1]] + phone <- Sys.getenv("USERPHONE") + email <- Sys.getenv("USEREMAIL") # make vectors of vals units <- unlist( @@ -241,22 +246,25 @@ getContainerPrivileges <- function(group, unit = NULL) { } # Look up org, role and unit name - org <- vector() - role <- vector() - name <- vector() - for (i in seq_len(length(units))) { - org[i] <- unitAttribute(units[i], "resh") - role[i] <- unitAttribute(units[i], "role") - name[i] <- unitAttribute(units[i], "titlewithpath") + orgs <- vector() + roles <- vector() + orgNames <- vector() + for (i in seq_len(length(units))) { + orgs[i] <- unitAttribute(units[i], "resh") + roles[i] <- unitAttribute(units[i], "role") + orgNames[i] <- unitAttribute(units[i], "titlewithpath") } list( - user = rep(user, length(units)), + name = rep(name, length(units)), + fullName = rep(fullName, length(units)), + phone = rep(phone, length(units)), + email = rep(email, length(units)), group = groups, unit = units, - org = org, - role = role, - orgName = name + org = orgs, + role = roles, + orgName = orgNames ) } diff --git a/man/autoReport.Rd b/man/autoReport.Rd index 118b2f91..a6f31d05 100644 --- a/man/autoReport.Rd +++ b/man/autoReport.Rd @@ -12,6 +12,7 @@ \alias{autoReportApp} \alias{orgList2df} \alias{autoReportFormatServer} +\alias{autoReportServer2} \title{Shiny modules and helper functions for registry auto reports} \usage{ autoReportUI(id) @@ -26,7 +27,7 @@ autoReportFormatServer(id) autoReportInput(id) -autoReportServer( +autoReportServer2( id, registryName, type, @@ -37,9 +38,7 @@ autoReportServer( orgs = NULL, eligible = TRUE, freq = "month", - userName = shiny::reactiveVal(getUserName(session)), - userOrg = shiny::reactiveVal(getUserReshId(session)), - userRole = shiny::reactiveVal(getUserRole(session)) + user ) autoReportApp( @@ -113,6 +112,11 @@ see \code{\link{navbarWidgetServer}}.} Default value set to \code{shiny::reactiveVal(getUserRole(session))}. For applications run under shinyproxy this value must be explicitly defined, see \code{\link{navbarWidgetServer}}.} + +\item{userEmail}{Shiny reactive value character string providing user email. +Default value set to \code{shiny::reactiveVal(getUserEmail(session))}. For +applications run under shinyproxy this value must be explicitly defined, +see \code{\link{navbarWidgetServer}}.} } \value{ In general, shiny objects. In particular, \code{autoreportOrgServer} @@ -143,10 +147,10 @@ These named values will be used to run reports none-interactively on a given schedule and must therefore represent existing and exported functions from the registry R package. For subscriptions the \emph{reports} list can be used as is, more specifically that the values provided in \emph{paramValues} can -go unchanged. For dispatchments and bulletins it is likely that parameter -values must be set dynamically in which case \emph{paramValues} must be -a reactive part of the application. See Examples on how function arguments -may be used as reactives in an application. +go unchanged. It is likely that parameter values must be set dynamically at +runtime in which case \emph{paramValues} must be a reactive part of the +application. See Examples on how function arguments may be used as reactives +in an application. } \examples{ ## make a list for report metadata diff --git a/man/getContainerPrivileges.Rd b/man/getContainerPrivileges.Rd deleted file mode 100644 index 19283778..00000000 --- a/man/getContainerPrivileges.Rd +++ /dev/null @@ -1,33 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/userAttribute.R -\name{getContainerPrivileges} -\alias{getContainerPrivileges} -\title{IN CONSTRUCTION: Get environmental variables for for container apps.} -\usage{ -getContainerPrivileges(group, unit = NULL) -} -\arguments{ -\item{group}{Character string providing the name of the app R package name. -The term "group" is used to relate to the environmental variable -SHINYPROXY_USERGROUPS that corresponds to the apps a given user can access.} - -\item{unit}{Integer providing the look-up unit id. Default value is NULL in -which case all privileges for \code{group} are returned.} -} -\value{ -List of privileges: - \describe{ - \item{user}{The username for whom the privileges apply.} - \item{group}{Group of which the user is a member.} - \item{unit}{Unit id under which the privileges are defined.} - \item{org}{Organization id for the user.} - \item{role}{Role of the user.} - \item{orgName}{Name of the organization as defined under the unit id.} - } -} -\description{ -For apps running as containers particular environment variables must be -defined for an orderly handling of dynamic user privileges. This function -makes use of environmental variables defined by shinyproxy to provide -available privileges for the shiny application -} diff --git a/man/navbarWidget.Rd b/man/navbarWidget.Rd index 3fcb369c..c51ce3e0 100644 --- a/man/navbarWidget.Rd +++ b/man/navbarWidget.Rd @@ -23,7 +23,7 @@ navbarWidgetApp(orgName = "Org Name") \item{addUserInfo}{Logical defining if an "about" hyperlink is to be added} \item{selectOrganization}{Logical providing option for selecting among -available organizations.} +available organizations and roles.} \item{orgName}{Character string naming the organization} @@ -37,7 +37,9 @@ called from outside the registry environment \code{caller} must be set to the actual name of the R package.} } \value{ -Shiny objects, mostly. Helper functions may return other stuff too. +Shiny objects, mostly. \code{navbarWidgetServer()} invisibly returns +a list of reactive values representing user metadata and privileges. See +\code{\link{userAttribute}} for further details on these values. } \description{ Shiny modules for making a user information widget in registry shiny apps at diff --git a/man/userAttribute.Rd b/man/userAttribute.Rd index aec740de..91fd9f8b 100644 --- a/man/userAttribute.Rd +++ b/man/userAttribute.Rd @@ -9,8 +9,10 @@ \alias{getUserPhone} \alias{getUserReshId} \alias{getUserRole} -\title{Get user attributes} +\title{IN CONSTRUCTION: Get environmental variables for for container apps.} \usage{ +userAttribute(group, unit = NULL) + getUserEmail(shinySession = NULL, group = NULL) getUserFullName(shinySession = NULL, group = NULL) @@ -26,18 +28,39 @@ getUserReshId(shinySession = NULL, group = NULL) getUserRole(shinySession = NULL, group = NULL) } \arguments{ -\item{shinySession}{A shiny session object. Default value is NULL} - \item{group}{Character string providing the name of the app R package name. The term "group" is used to relate to the environmental variable SHINYPROXY_USERGROUPS that corresponds to the apps a given user can access. Default value is NULL but should always be set when shiny app is run as a shinyproxy container.} + +\item{unit}{Integer providing the look-up unit id. Default value is NULL in +which case all privileges for \code{group} are returned.} + +\item{shinySession}{A shiny session object. Default value is NULL} } \value{ +Invisibly a list of user metadata and privileges: + \describe{ + \item{name}{The username for whom the privileges apply.} + \item{fullName}{User full name} + \item{phone}{User phone number} + \item{email}{User email} + \item{group}{Group of which the user is a member.} + \item{unit}{Unit id under which the privileges are defined.} + \item{org}{Organization id for the user.} + \item{role}{Role of the user.} + \item{orgName}{Name of the organization as defined under the unit id.} + } + String with user attribute } \description{ +For apps running as containers particular environment variables must be +defined for an orderly handling of dynamic user privileges. This function +makes use of environmental variables defined by shinyproxy to provide +available privileges for the shiny application + These are helper function for \code{\link{userInfo}}. When used without a shiny session object calls to these functions is made without any arguments. If redefining contexts is needed, please use \code{\link{userInfo}} instead. diff --git a/tests/testthat/test-userInfo.R b/tests/testthat/test-userInfo.R index 5987662c..be5bb961 100644 --- a/tests/testthat/test-userInfo.R +++ b/tests/testthat/test-userInfo.R @@ -140,12 +140,13 @@ file.copy( with_envvar( new = c( - "SHINYPROXY_USERGROUPS" = "rapbase" + "SHINYPROXY_USERGROUPS" = "rapbase", + "USERORGID" = "" ), code = { test_that("errors are returned when insufficient system environment", { expect_error( - getContainerPrivileges("rapbase"), + userAttribute("rapbase"), regexp = "Environmental variables SHINYPROXY_USERGROUPS and USERORGID") }) } @@ -153,12 +154,13 @@ with_envvar( with_envvar( new = c( + "SHINYPROXY_USERGROUPS" = "", "USERORGID" = "1" ), code = { test_that("errors are returned when insufficient system environment", { expect_error( - getContainerPrivileges("rapbase"), + userAttribute("rapbase"), regexp = "Environmental variables SHINYPROXY_USERGROUPS and USERORGID") }) } @@ -172,7 +174,7 @@ with_envvar( code = { test_that("error is returned when environment elements are not equal", { expect_error( - getContainerPrivileges("rapbase"), + userAttribute("rapbase"), regexp = "Vectors obtained from SHINYPROXY_USERGROUPS and USERORGID") }) } @@ -185,16 +187,16 @@ with_envvar( ), code = { test_that("group and unit are returned correspondingly when unit = NULL", { - expect_true(class(getContainerPrivileges("rapbase")) == "list") + expect_true(class(userAttribute("rapbase")) == "list") expect_true( - length(getContainerPrivileges("rapbase")$group) == - length(getContainerPrivileges("rapbase")$unit) + length(userAttribute("rapbase")$group) == + length(userAttribute("rapbase")$unit) ) - expect_true(length(getContainerPrivileges("rapbase")$group) == 2) - expect_true(getContainerPrivileges("rapbase")$group[1] == "rapbase") - expect_true(getContainerPrivileges("rapbase")$group[2] == "rapbase") - expect_true(getContainerPrivileges("rapbase")$unit[1] == "1") - expect_true(getContainerPrivileges("rapbase")$unit[2] == "2") + expect_true(length(userAttribute("rapbase")$group) == 2) + expect_true(userAttribute("rapbase")$group[1] == "rapbase") + expect_true(userAttribute("rapbase")$group[2] == "rapbase") + expect_true(userAttribute("rapbase")$unit[1] == "1") + expect_true(userAttribute("rapbase")$unit[2] == "2") }) } ) @@ -205,17 +207,17 @@ with_envvar( "USERORGID" = "[1, 2, 3, 4]" ), code = { - test_that("group and unit are returned correspondingly when unit is given", { - expect_true(class(getContainerPrivileges("rapbase")) == "list") + test_that("group and unit returned correspondingly when unit is given", { + expect_true(class(userAttribute("rapbase")) == "list") expect_true( - length(getContainerPrivileges("rapbase", unit = 2)$group) == - length(getContainerPrivileges("rapbase", unit = 2)$unit) + length(userAttribute("rapbase", unit = 2)$group) == + length(userAttribute("rapbase", unit = 2)$unit) ) expect_true( - getContainerPrivileges("rapbase", unit = 2)$unit == 2 + userAttribute("rapbase", unit = 2)$unit == 2 ) expect_true( - getContainerPrivileges("utils", unit = 3)$unit == 3 + userAttribute("utils", unit = 3)$unit == 3 ) }) } @@ -229,10 +231,10 @@ with_envvar( code = { test_that("correct lookup values are provided", { expect_true( - getContainerPrivileges("rapbase", unit = 2)$org == 102966 + userAttribute("rapbase", unit = 2)$org == 102966 ) expect_true( - getContainerPrivileges("utils", unit = 3)$role == "SC" + userAttribute("utils", unit = 3)$role == "SC" ) }) } From 22225f76fe1b7b9d06cd08362fd7a6c413a918dc Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 10 Oct 2022 09:39:19 +0200 Subject: [PATCH 25/79] container custom made widget server --- NAMESPACE | 2 +- R/moduleNavbarWidget.R | 57 +++++++++++++++++++----------------------- man/navbarWidget.Rd | 4 +-- 3 files changed, 29 insertions(+), 34 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index c4035473..b8f92b5b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -56,7 +56,7 @@ export(mst) export(mtimeStagingData) export(navbarWidgetApp) export(navbarWidgetInput) -export(navbarWidgetServer) +export(navbarWidgetServer2) export(noOptOutOk) export(orgList2df) export(rapCloseDbConnection) diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index e5b7840f..d5a02b31 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -26,7 +26,7 @@ #' a list of reactive values representing user metadata and privileges. See #' \code{\link{userAttribute}} for further details on these values. #' @name navbarWidget -#' @aliases navbarWidgetInput navbarWidgetServer navbarWidgetApp +#' @aliases navbarWidgetInput navbarWidgetServer2 navbarWidgetApp #' @examples #' ## client user interface function #' ui <- shiny::tagList( @@ -76,7 +76,7 @@ navbarWidgetInput <- function(id, #' @rdname navbarWidget #' @export -navbarWidgetServer <- function( +navbarWidgetServer2 <- function( id, orgName, caller = environmentName(topenv(parent.frame())) @@ -84,17 +84,20 @@ navbarWidgetServer <- function( shiny::moduleServer(id, function(input, output, session) { - # to be populated further if and when inside an app container + user <- userAttribute(caller) + stopifnot(length(user$name) > 0) + + # Initial privileges and affiliation will be first in list rv <- shiny::reactiveValues( - name = getUserName(session, caller), - fullName = getUserFullName(session, caller), - phone = NULL, - email = NULL, - group = caller, - unit = NULL, - org = getUserReshId(session, caller), - role = getUserRole(session, caller), - orgName = NULL + name = user$name[1], + fullName = user$fullName[1], + phone = user$phone[1], + email = user$email[1], + group = user$group[1], + unit = user$unit[1], + org = user$org[1], + role = user$role[1], + orgName = user$orgName[1] ) output$name <- shiny::renderText(rv$fullName) @@ -116,13 +119,9 @@ navbarWidgetServer <- function( # Select organization in widget (for container apps only) shiny::observeEvent(input$selectOrganization, { - - ## Start MOVE OUTSIDE observer when we are all containers ------------- ## - privs <- userAttribute(caller) - ## End MOVE OUTSIDE --------------------------------------------------- ## - choices <- privs$unit + choices <- user$unit names(choices) <- paste0( - privs$orgName, " (", privs$org, ") - ", privs$role + user$orgName, " (", user$org, ") - ", user$role ) shinyalert::shinyalert( @@ -153,19 +152,15 @@ navbarWidgetServer <- function( }) shiny::observeEvent(input$unit, { - ## Start MOVE OUTSIDE observer when we are all containers ------------- ## - privs <- userAttribute(caller) - ## End MOVE OUTSIDE --------------------------------------------------- ## - - rv$name <- privs$name[privs$unit == input$unit] - rv$fullName <- privs$fullName[privs$unit == input$unit] - rv$phone <- privs$phone[privs$unit == input$unit] - rv$email <- privs$email[privs$unit == input$unit] - rv$group <- privs$group[privs$unit == input$unit] - rv$unit <- privs$unit[privs$unit == input$unit] - rv$org <- privs$org[privs$unit == input$unit] - rv$role <- privs$role[privs$unit == input$unit] - rv$orgName <- privs$orgName[privs$unit == input$unit] + rv$name <- user$name[user$unit == input$unit] + rv$fullName <- user$fullName[user$unit == input$unit] + rv$phone <- user$phone[user$unit == input$unit] + rv$email <- user$email[user$unit == input$unit] + rv$group <- user$group[user$unit == input$unit] + rv$unit <- user$unit[user$unit == input$unit] + rv$org <- user$org[user$unit == input$unit] + rv$role <- user$role[user$unit == input$unit] + rv$orgName <- user$orgName[user$unit == input$unit] }) invisible( diff --git a/man/navbarWidget.Rd b/man/navbarWidget.Rd index c51ce3e0..f052cca6 100644 --- a/man/navbarWidget.Rd +++ b/man/navbarWidget.Rd @@ -3,13 +3,13 @@ \name{navbarWidget} \alias{navbarWidget} \alias{navbarWidgetInput} -\alias{navbarWidgetServer} +\alias{navbarWidgetServer2} \alias{navbarWidgetApp} \title{Shiny modules providing GUI and server logic for user info widget} \usage{ navbarWidgetInput(id, addUserInfo = TRUE, selectOrganization = FALSE) -navbarWidgetServer( +navbarWidgetServer2( id, orgName, caller = environmentName(topenv(parent.frame())) From de2083a7ec6ea1c4f8c3dc6674b792bf7629cd16 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 10 Oct 2022 14:20:45 +0200 Subject: [PATCH 26/79] might work, in fact :-) --- R/moduleAutoReport.R | 47 +++++++++++++++++++++----------------------- 1 file changed, 22 insertions(+), 25 deletions(-) diff --git a/R/moduleAutoReport.R b/R/moduleAutoReport.R index 3c919894..9183858f 100644 --- a/R/moduleAutoReport.R +++ b/R/moduleAutoReport.R @@ -273,9 +273,9 @@ autoReportServer2 <- function( tab = makeAutoReportTab( session = session, namespace = id, - user = user$name(), + user = NULL, group = registryName, - orgId = user$org(), + orgId = NULL, type = type, mapOrgId = orgList2df(orgs) ), @@ -285,6 +285,24 @@ autoReportServer2 <- function( email = vector() ) + ## update tab whenever changes to user privileges (and on init) + userEvent <- shiny::reactive( + list(user$name(), user$org(), user$role()) + ) + shiny::observeEvent( + userEvent(), + autoReport$tab <- makeAutoReportTab( + session = session, + namespace = id, + user = user$name(), + group = registryName, + orgId = user$org(), + type = type, + mapOrgId = orgList2df(orgs) + ), + ignoreNULL = FALSE + ) + shiny::observeEvent(input$addEmail, { autoReport$email <- c(autoReport$email, input$email) }) @@ -307,8 +325,6 @@ autoReportServer2 <- function( email <- autoReport$email } if (!paramValues()[1] == "") { - print(paste("paramName:", paramNames())) - print(paste("paramValue:", paramValues())) stopifnot(length(paramNames()) == length(paramValues())) for (i in seq_len(length(paramNames()))) { paramValues[paramNames == paramNames()[i]] <- paramValues()[i] @@ -540,16 +556,7 @@ autoReportServer2 <- function( }) output$activeReports <- DT::renderDataTable( - #autoReport$tab, - makeAutoReportTab( - session, - namespace = id, - user = user$name(), - group = registryName, - orgId = user$org(), - type = type, - mapOrgId = orgList2df(orgs) - ), + autoReport$tab, server = FALSE, escape = FALSE, selection = "none", rownames = FALSE, options = list( @@ -570,17 +577,7 @@ autoReportServer2 <- function( shiny::p("Ved sp\u00F8rsm\u00E5l ta gjerne kontakt med registeret."), shiny::hr() ) - } else if (length( - makeAutoReportTab( - session, - namespace = id, - user = user$name(), - group = registryName, - orgId = user$org(), - type = type, - mapOrgId = orgList2df(orgs) - ) - ) == 0) { + } else if (length(autoReport$tab) == 0) { shiny::tagList( shiny::h2("Det finnes ingen oppf\u00F8ringer"), shiny::p(paste( From ef3e2540dcea427997b3da819d3494cd190ac303 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 10 Oct 2022 15:10:48 +0200 Subject: [PATCH 27/79] re-intro of old funs and general clean-up --- NAMESPACE | 2 + R/moduleAutoReport.R | 351 +++++++++++++++++++++++++++++++++++++++-- R/moduleNavbarWidget.R | 33 +++- R/userAttribute.R | 4 +- _pkgdown.yml | 1 + man/autoReport.Rd | 35 ++-- man/navbarWidget.Rd | 3 + man/userAttribute.Rd | 4 +- 8 files changed, 390 insertions(+), 43 deletions(-) diff --git a/NAMESPACE b/NAMESPACE index b8f92b5b..e89b7b54 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,6 +13,7 @@ export(autoReportFormatServer) export(autoReportInput) export(autoReportOrgInput) export(autoReportOrgServer) +export(autoReportServer) export(autoReportServer2) export(autoReportUI) export(cleanStagingData) @@ -56,6 +57,7 @@ export(mst) export(mtimeStagingData) export(navbarWidgetApp) export(navbarWidgetInput) +export(navbarWidgetServer) export(navbarWidgetServer2) export(noOptOutOk) export(orgList2df) diff --git a/R/moduleAutoReport.R b/R/moduleAutoReport.R index 9183858f..3fe1e0e3 100644 --- a/R/moduleAutoReport.R +++ b/R/moduleAutoReport.R @@ -60,23 +60,9 @@ #' report GUI. Must be one of #' \code{c("day", "week", "month", "quarter", "year")}. Default value is #' "month". -#' @param userName Shiny reactive value character string providing user name. -#' Default value set to \code{shiny::reactiveVal(getUserName(session))}. For -#' applications run under shinyproxy this value must be explicitly defined, -#' see \code{\link{navbarWidgetServer}}. -#' @param userOrg Shiny reactive value character string providing user org id. -#' Default value set to \code{shiny::reactiveVal(getUserReshId(session))}. For -#' applications run under shinyproxy this value must be explicitly defined, -#' see \code{\link{navbarWidgetServer}}. -#' @param userRole Shiny reactive value character string providing user role. -#' Default value set to \code{shiny::reactiveVal(getUserRole(session))}. For -#' applications run under shinyproxy this value must be explicitly defined, -#' see \code{\link{navbarWidgetServer}}. -#' @param userEmail Shiny reactive value character string providing user email. -#' Default value set to \code{shiny::reactiveVal(getUserEmail(session))}. For -#' applications run under shinyproxy this value must be explicitly defined, -#' see \code{\link{navbarWidgetServer}}. -#' +#' @param user List of shiny reactive values providing user metadata and +#' privileges corresponding to the return value of +#' \code{\link{navbarWidgetServer}}. #' #' @return In general, shiny objects. In particular, \code{autoreportOrgServer} #' returns a list with names "name" and "value" with corresponding reactive @@ -235,6 +221,337 @@ autoReportInput <- function(id) { ) } +#' @rdname autoReport +#' @export +autoReportServer <- function(id, registryName, type, org = NULL, + paramNames = shiny::reactiveVal(c("")), + paramValues = shiny::reactiveVal(c("")), + reports = NULL, orgs = NULL, eligible = TRUE, + freq = "month") { + if (!type %in% c("subscription")) { + stopifnot(shiny::is.reactive(org)) + stopifnot(shiny::is.reactive(paramNames)) + stopifnot(shiny::is.reactive(paramValues)) + } + + stopifnot(freq %in% c("day", "week", "month", "quarter", "year")) + + defaultFreq <- switch(freq, + day = "Daglig-day", + week = "Ukentlig-week", + month = "M\u00E5nedlig-month", + quarter = "Kvartalsvis-quarter", + year = "\u00C5rlig-year" + ) + + shiny::moduleServer(id, function(input, output, session) { + autoReport <- shiny::reactiveValues( + tab = makeAutoReportTab( + session = session, + namespace = id, + type = type, + mapOrgId = orgList2df(orgs) + ), + report = names(reports)[1], + org = unlist(orgs, use.names = FALSE)[1], + freq = defaultFreq, + email = vector() + ) + + shiny::observeEvent(input$addEmail, { + autoReport$email <- c(autoReport$email, input$email) + }) + + shiny::observeEvent(input$delEmail, { + autoReport$email <- autoReport$email[!autoReport$email == input$email] + }) + + shiny::observeEvent(input$makeAutoReport, { + report <- reports[[input$report]] + interval <- strsplit(input$freq, "-")[[1]][2] + paramValues <- report$paramValues + paramNames <- report$paramNames + + if (type %in% c("subscription") | is.null(orgs)) { + email <- getUserEmail(session) + organization <- getUserReshId(session) + } else { + organization <- org() + if (!paramValues()[1] == "") { + stopifnot(length(paramNames()) == length(paramValues())) + for (i in seq_len(length(paramNames()))) { + paramValues[paramNames == paramNames()[i]] <- paramValues()[i] + } + } + email <- autoReport$email + } + + createAutoReport( + synopsis = report$synopsis, + package = registryName, + type = type, + fun = report$fun, + paramNames = report$paramNames, + paramValues = paramValues, + owner = rapbase::getUserName(session), + ownerName = rapbase::getUserFullName(session), + email = email, + organization = organization, + runDayOfYear = makeRunDayOfYearSequence( + interval = interval, + startDay = input$start + ), + startDate = input$start, + interval = interval, + intervalName = strsplit(input$freq, "-")[[1]][1] + ) + autoReport$tab <- + makeAutoReportTab( + session, + namespace = id, + type = type, + mapOrgId = orgList2df(orgs) + ) + autoReport$email <- vector() + }) + + shiny::observeEvent(input$edit_button, { + repId <- strsplit(input$edit_button, "__")[[1]][2] + rep <- readAutoReportData()[[repId]] + + # try matching report by synopsis, fallback to currently selected + for (i in names(reports)) { + if (reports[[i]]$synopsis == rep$synopsis) { + autoReport$report <- i + } + } + autoReport$org <- rep$organization + autoReport$freq <- paste0(rep$intervalName, "-", rep$interval) + autoReport$email <- rep$email + deleteAutoReport(repId) + autoReport$tab <- makeAutoReportTab( + session, + namespace = id, + type = type, + mapOrgId = orgList2df(orgs) + ) + + if (rep$type == "subscription") { + + } + if (rep$type == "dispatchment") { + + } + if (rep$type == "bulletin") { + + } + }) + + shiny::observeEvent(input$del_button, { + repId <- strsplit(input$del_button, "__")[[1]][2] + deleteAutoReport(repId) + autoReport$tab <- makeAutoReportTab( + session, + namespace = id, + type = type, + mapOrgId = orgList2df(orgs) + ) + }) + + # outputs + output$reports <- shiny::renderUI({ + if (is.null(reports)) { + NULL + } else { + shiny::selectInput( + shiny::NS(id, "report"), + label = shiny::tags$div( + shiny::HTML(as.character(shiny::icon("file")), "Velg rapport:") + ), + choices = names(reports), + selected = autoReport$report + ) + } + }) + + output$synopsis <- shiny::renderUI({ + shiny::req(input$report) + shiny::HTML( + paste0( + "Rapportbeskrivelse:
", + reports[[input$report]]$synopsis, + "" + ) + ) + }) + + output$freq <- shiny::renderUI({ + shiny::selectInput( + shiny::NS(id, "freq"), + label = shiny::tags$div( + shiny::HTML(as.character(shiny::icon("clock")), "Frekvens:") + ), + choices = list( + "Aarlig" = "\u00C5rlig-year", + "Kvartalsvis" = "Kvartalsvis-quarter", + "Maanedlig" = "M\u00E5nedlig-month", + "Ukentlig" = "Ukentlig-week", + "Daglig" = "Daglig-day" + ), + selected = autoReport$freq + ) + }) + + output$start <- shiny::renderUI({ + shiny::req(input$freq) + shiny::dateInput( + shiny::NS(id, "start"), + label = shiny::tags$div( + shiny::HTML( + as.character(shiny::icon("calendar")), "F\u00F8rste utsending:" + ) + ), + # if freq is year make first issue tomorrow, otherwise postpone by freq + value = if (strsplit(input$freq, "-")[[1]][2] == "year") { + Sys.Date() + 1 + } else { + seq.Date(Sys.Date(), + by = strsplit(input$freq, "-")[[1]][2], + length.out = 2 + )[2] + }, + min = Sys.Date() + 1, + max = seq.Date(Sys.Date(), length.out = 2, by = "1 years")[2] - 1 + ) + }) + + output$email <- shiny::renderUI({ + if (type %in% c("dispatchment", "bulletin")) { + shiny::textInput( + shiny::NS(id, "email"), + label = shiny::tags$div( + shiny::HTML(as.character(shiny::icon("at")), "E-post mottaker:") + ), + value = "gyldig@epostadresse.no" + ) + } else { + NULL + } + }) + + output$editEmail <- shiny::renderUI({ + if (type %in% c("dispatchment", "bulletin")) { + shiny::req(input$email) + if (!grepl( + "^[A-Za-z0-9._%+-]+@[A-Za-z0-9.-]+\\.[A-Za-z]{2,}$", + input$email + )) { + NULL + } else { + if (input$email %in% autoReport$email) { + shiny::actionButton( + shiny::NS(id, "delEmail"), + shiny::HTML(paste("Slett mottaker
", input$email)), + icon = shiny::icon("minus-square") + ) + } else { + shiny::actionButton( + shiny::NS(id, "addEmail"), + shiny::HTML(paste("Legg til mottaker
", input$email)), + icon = shiny::icon("plus-square") + ) + } + } + } else { + NULL + } + }) + + output$recipient <- shiny::renderUI({ + if (type %in% c("dispatchment", "bulletin")) { + recipientList <- paste0(autoReport$email, sep = "
", collapse = "") + shiny::HTML(paste0("Mottakere:
", recipientList)) + } else { + NULL + } + }) + + output$makeAutoReport <- shiny::renderUI({ + if (is.null(autoReport$report) || !eligible) { + NULL + } else { + if (type %in% c("subscription")) { + shiny::actionButton( + shiny::NS(id, "makeAutoReport"), + "Lag oppf\u00F8ring", + icon = shiny::icon("save") + ) + } else { + shiny::req(input$email) + if (length(autoReport$email) == 0) { + NULL + } else { + shiny::actionButton( + shiny::NS(id, "makeAutoReport"), + "Lag oppf\u00F8ring", + icon = shiny::icon("save") + ) + } + } + } + }) + + output$activeReports <- DT::renderDataTable( + autoReport$tab, + server = FALSE, escape = FALSE, selection = "none", + rownames = FALSE, + options = list( + dom = "tp", ordering = FALSE, + language = list( + lengthMenu = "Vis _MENU_ rader per side", + search = "S\u00f8k:", + info = "Rad _START_ til _END_ av totalt _TOTAL_", + paginate = list(previous = "Forrige", `next` = "Neste") + ) + ) + ) + + output$autoReportTable <- shiny::renderUI({ + if (!eligible) { + shiny::tagList( + shiny::h2(paste0("Funksjonen ('", type, "') er utilgjengelig")), + shiny::p("Ved sp\u00F8rsm\u00E5l ta gjerne kontakt med registeret."), + shiny::hr() + ) + } else if (length(autoReport$tab) == 0) { + shiny::tagList( + shiny::h2("Det finnes ingen oppf\u00F8ringer"), + shiny::p(paste( + "Nye oppf\u00F8ringer kan lages fra menyen til", + "venstre. Bruk gjerne veiledingen under." + )), + shiny::htmlOutput(shiny::NS(id, "autoReportGuide")) + ) + } else { + shiny::tagList( + shiny::h2("Aktive oppf\u00F8ringer:"), + DT::dataTableOutput(shiny::NS(id, "activeReports")), + shiny::htmlOutput(shiny::NS(id, "autoReportGuide")) + ) + } + }) + + output$autoReportGuide <- shiny::renderUI({ + renderRmd( + sourceFile = system.file("autoReportGuide.Rmd", package = "rapbase"), + outputType = "html_fragment", + params = list(registryName = registryName, type = type) + ) + }) + }) +} + + #' @rdname autoReport #' @export autoReportServer2 <- function( diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index d5a02b31..7e0d823f 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -74,6 +74,33 @@ navbarWidgetInput <- function(id, ) } +#' @rdname navbarWidget +#' @export +navbarWidgetServer <- function(id, orgName, + caller = environmentName(rlang::caller_env())) { + shiny::moduleServer(id, function(input, output, session) { + output$name <- shiny::renderText(rapbase::getUserFullName(session)) + output$affiliation <- shiny::renderText( + paste(orgName, getUserRole(session), sep = ", ") + ) + + # User info in widget + userInfo <- howWeDealWithPersonalData(session, callerPkg = caller) + shiny::observeEvent(input$userInfo, { + shinyalert::shinyalert( + "Dette vet Rapporteket om deg:", + userInfo, + type = "", imageUrl = "rap/logo.svg", + closeOnEsc = TRUE, + closeOnClickOutside = TRUE, + html = TRUE, + confirmButtonText = rapbase::noOptOutOk() + ) + }) + }) +} + + #' @rdname navbarWidget #' @export navbarWidgetServer2 <- function( @@ -130,9 +157,9 @@ navbarWidgetServer2 <- function( text = shiny::tagList(shiny::tagList( shiny::p( paste( - "Velg organisasjon og rolle du ønsker å representere for", - orgName, "i Rapporteket og trykk OK.", - "Dine valgmuligheter er basert på de tilganger som er satt.", + "Velg organisasjon og rolle du \u00f8nsker \u00e5 representere", + "for", orgName, "i Rapporteket og trykk OK.", + "Dine valgmuligheter er basert p\u00e5 de tilganger som er satt.", "Ta kontakt med registeret om du mener at lista over valg", "ikke er riktg." ) diff --git a/R/userAttribute.R b/R/userAttribute.R index 51949e9d..76ac6caa 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -168,12 +168,12 @@ userInfo <- function( } -#' IN CONSTRUCTION: Get environmental variables for for container apps. +#' User attributes in container apps running behind shinyproxy #' #' For apps running as containers particular environment variables must be #' defined for an orderly handling of dynamic user privileges. This function #' makes use of environmental variables defined by shinyproxy to provide -#' available privileges for the shiny application +#' available privileges for the shiny application. #' #' @param group Character string providing the name of the app R package name. #' The term "group" is used to relate to the environmental variable diff --git a/_pkgdown.yml b/_pkgdown.yml index 0743e947..8e113148 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -45,6 +45,7 @@ reference: - getUserEmail - userInfo - unitAttribute + - userAttribute - title: Logging desc: > diff --git a/man/autoReport.Rd b/man/autoReport.Rd index a6f31d05..ad0daa7d 100644 --- a/man/autoReport.Rd +++ b/man/autoReport.Rd @@ -27,6 +27,19 @@ autoReportFormatServer(id) autoReportInput(id) +autoReportServer( + id, + registryName, + type, + org = NULL, + paramNames = shiny::reactiveVal(c("")), + paramValues = shiny::reactiveVal(c("")), + reports = NULL, + orgs = NULL, + eligible = TRUE, + freq = "month" +) + autoReportServer2( id, registryName, @@ -98,25 +111,9 @@ report GUI. Must be one of \code{c("day", "week", "month", "quarter", "year")}. Default value is "month".} -\item{userName}{Shiny reactive value character string providing user name. -Default value set to \code{shiny::reactiveVal(getUserName(session))}. For -applications run under shinyproxy this value must be explicitly defined, -see \code{\link{navbarWidgetServer}}.} - -\item{userOrg}{Shiny reactive value character string providing user org id. -Default value set to \code{shiny::reactiveVal(getUserReshId(session))}. For -applications run under shinyproxy this value must be explicitly defined, -see \code{\link{navbarWidgetServer}}.} - -\item{userRole}{Shiny reactive value character string providing user role. -Default value set to \code{shiny::reactiveVal(getUserRole(session))}. For -applications run under shinyproxy this value must be explicitly defined, -see \code{\link{navbarWidgetServer}}.} - -\item{userEmail}{Shiny reactive value character string providing user email. -Default value set to \code{shiny::reactiveVal(getUserEmail(session))}. For -applications run under shinyproxy this value must be explicitly defined, -see \code{\link{navbarWidgetServer}}.} +\item{user}{List of shiny reactive values providing user metadata and +privileges corresponding to the return value of +\code{\link{navbarWidgetServer}}.} } \value{ In general, shiny objects. In particular, \code{autoreportOrgServer} diff --git a/man/navbarWidget.Rd b/man/navbarWidget.Rd index f052cca6..5d5163ec 100644 --- a/man/navbarWidget.Rd +++ b/man/navbarWidget.Rd @@ -5,10 +5,13 @@ \alias{navbarWidgetInput} \alias{navbarWidgetServer2} \alias{navbarWidgetApp} +\alias{navbarWidgetServer} \title{Shiny modules providing GUI and server logic for user info widget} \usage{ navbarWidgetInput(id, addUserInfo = TRUE, selectOrganization = FALSE) +navbarWidgetServer(id, orgName, caller = environmentName(rlang::caller_env())) + navbarWidgetServer2( id, orgName, diff --git a/man/userAttribute.Rd b/man/userAttribute.Rd index 91fd9f8b..393d4491 100644 --- a/man/userAttribute.Rd +++ b/man/userAttribute.Rd @@ -9,7 +9,7 @@ \alias{getUserPhone} \alias{getUserReshId} \alias{getUserRole} -\title{IN CONSTRUCTION: Get environmental variables for for container apps.} +\title{User attributes in container apps running behind shinyproxy} \usage{ userAttribute(group, unit = NULL) @@ -59,7 +59,7 @@ String with user attribute For apps running as containers particular environment variables must be defined for an orderly handling of dynamic user privileges. This function makes use of environmental variables defined by shinyproxy to provide -available privileges for the shiny application +available privileges for the shiny application. These are helper function for \code{\link{userInfo}}. When used without a shiny session object calls to these functions is made without any arguments. From 6b5942fe6d68d111fb8e8fb3123833256c6a7786 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 11 Oct 2022 09:18:14 +0200 Subject: [PATCH 28/79] also working on 3.6? --- R/userAttribute.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/userAttribute.R b/R/userAttribute.R index 76ac6caa..c9055193 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -145,7 +145,7 @@ userInfo <- function( if (context %in% c("QAC", "PRODUCTIONC")) { userprivs <- userAttribute(group) # pick the first of available user privileges - userprivs <- as.data.frame(userprivs)[1, ] + userprivs <- as.data.frame(userprivs, stringsAsFactors = FALSE)[1, ] user <- userprivs$name groups <- userprivs$group resh_id <- userprivs$org From f1bb84619436a3c3d2ece646bc713651ed80ce10 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 11 Oct 2022 14:20:58 +0200 Subject: [PATCH 29/79] unit test follow-up --- R/moduleNavbarWidget.R | 2 +- tests/testthat/test-moduleAutoReport.R | 275 +++++++++++++++++++++++ tests/testthat/test-moduleNavbarWidget.R | 36 +++ 3 files changed, 312 insertions(+), 1 deletion(-) diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index 7e0d823f..abc7cc8d 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -225,7 +225,7 @@ navbarWidgetApp <- function(orgName = "Org Name") { ) ) server <- function(input, output, session) { - privs <- navbarWidgetServer("testWidget", orgName = orgName) + navbarWidgetServer("testWidget", orgName = orgName) } shiny::shinyApp(ui, server) diff --git a/tests/testthat/test-moduleAutoReport.R b/tests/testthat/test-moduleAutoReport.R index 82320348..24aedbba 100644 --- a/tests/testthat/test-moduleAutoReport.R +++ b/tests/testthat/test-moduleAutoReport.R @@ -300,5 +300,280 @@ test_that("test app returns an app object", { expect_equal(class(autoReportApp()), "shiny.appobj") }) +## Duplicate for shinyproxy container instance +file.copy( + system.file( + c("autoReport.yml", "extdata/accesstree.json"), + package = "rapbase" + ), + Sys.getenv("R_RAP_CONFIG_PATH") +) +with_envvar( + new = c( + "R_RAP_INSTANCE" = "QAC", + "SHINYPROXY_USERNAME" = "ttesterc", + "SHINYPROXY_USERGROUPS" = "rapbase,rapbase,utils,utils", + "USERORGID" = "[1, 2, 3, 4]", + "USERFULLNAME" = "Tore Tester Container", + "USEREMAIL" = "ttesterc@rapporteket.no" + ), + code = { + ## make a list for report metadata + reports <- list( + FirstReport = list( + synopsis = "First example report", + fun = "fun1", + paramNames = c("organization", "outputFormat"), + paramValues = c(100082, "html") + ), + SecondReport = list( + synopsis = "Second example report", + fun = "fun2", + paramNames = c("organization", "outputFormat"), + paramValues = c(102966, "pdf") + ) + ) + ## make a list of organization names and numbers + orgs <- list( + OrgOne = 100082, + OrgTwo = 102966 + ) + type <- "subscription" + user <- userAttribute("rapbase", unit = 1) + for (n in names(user)) { + print(user[[n]]) + user[[n]] <- shiny::reactiveVal(user[[n]]) + } + + test_that("module server provides sensible output", { + shiny::testServer(autoReportServer2, + args = list( + registryName = registryName, type = type, + reports = reports, orgs = orgs, user = user + ), + { + session$setInputs(report = "FirstReport") + expect_equal(class(output$reports), "list") + } + ) + }) + + test_that("no report select list created when no reports available", { + shiny::testServer( + autoReportServer2, + args = list( + registryName = registryName, type = type, + reports = NULL, orgs = orgs, user = user + ), + { + expect_true(is.null(output$reports)) + } + ) + }) + + type <- "dispatchment" + test_that("email can be added and deleted for dispatchment", { + shiny::testServer( + autoReportServer2, + args = list( + registryName = registryName, type = type, + org = shiny::reactive(100082), + reports = reports, orgs = orgs, user = user + ), + { + session$setInputs(email = "true@email.no") + expect_equal(length(autoReport$email), 0) + session$setInputs(addEmail = 1) + expect_equal(autoReport$email[1], "true@email.no") + session$setInputs(delEmail = 1) + expect_equal(length(autoReport$email), 0) + } + ) + }) + + + test_that("new dispatchment can be written to and removed from file", { + origFileSize <- file.size(file.path( + Sys.getenv("R_RAP_CONFIG_PATH"), + "autoReport.yml" + )) + shiny::testServer( + autoReportServer2, + args = list( + registryName = registryName, type = type, + org = shiny::reactive(100082), + reports = reports, orgs = orgs, freq = "year", user = user + ), + { + user$role <- shiny::reactive("SC") + session$flushReact() + print(autoReport$tab) + session$setInputs(report = "FirstReport") + session$setInputs(freq = "Aarlig-year") + session$setInputs(start = as.character(Sys.Date())) + session$setInputs(email = "true@email.no") + session$setInputs(addEmail = 1) + session$setInputs(makeAutoReport = 1) + expect_true(origFileSize < file.size( + file.path( + Sys.getenv("R_RAP_CONFIG_PATH"), + "autoReport.yml" + ) + )) + + # get newly created edit button id (from last entry in table) + # and test it by entry being removed from table + btnRaw <- autoReport$tab[dim(autoReport$tab)[1], ]$Endre + editButton <- rvest::read_html(btnRaw) %>% + rvest::html_element("button") %>% + rvest::html_attr("id") + repsBefore <- dim(autoReport$tab)[1] + session$setInputs(edit_button = editButton) + repsAfter <- dim(autoReport$tab)[1] + expect_true(repsAfter == (repsBefore - 1)) + # then, true deletion (after adding one more time) + session$setInputs(makeAutoReport = 2) + expect_true(repsBefore == dim(autoReport$tab)[1]) + btnRaw <- autoReport$tab[dim(autoReport$tab)[1], ]$Slett + delButton <- rvest::read_html(btnRaw) %>% + rvest::html_element("button") %>% + rvest::html_attr("id") + session$setInputs(del_button = delButton) + repsAfter <- dim(autoReport$tab)[1] + expect_true(repsAfter == (repsBefore - 1)) + } + ) + }) + + test_that("paramValues can be tweaked when provided", { + origFileSize <- file.size(file.path( + Sys.getenv("R_RAP_CONFIG_PATH"), + "autoReport.yml" + )) + shiny::testServer( + autoReportServer2, + args = list( + registryName = registryName, type = type, + org = shiny::reactive(100082), + paramNames = shiny::reactive(c("organization", "outputFormat")), + paramValues = shiny::reactive(c(999999, "pdf")), + reports = reports, orgs = orgs, user = user + ), + { + session$setInputs(report = "FirstReport") + session$setInputs(freq = "Maanedlig-month") + session$setInputs(start = as.character(Sys.Date())) + session$setInputs(email = "true@email.no") + session$setInputs(addEmail = 1) + session$setInputs(makeAutoReport = 1) + expect_true(origFileSize < file.size( + file.path( + Sys.getenv("R_RAP_CONFIG_PATH"), + "autoReport.yml" + ) + )) + } + ) + }) + + test_that("new subscription can be written to and removed from file", { + origFileSize <- file.size(file.path( + Sys.getenv("R_RAP_CONFIG_PATH"), + "autoReport.yml" + )) + shiny::testServer( + autoReportServer2, + args = list( + registryName = registryName, type = "subscription", + org = shiny::reactive(100082), + reports = reports, orgs = orgs, user = user + ), + { + session$setInputs(report = "FirstReport") + session$setInputs(freq = "Maanedlig-month") + session$setInputs(start = as.character(Sys.Date())) + session$setInputs(makeAutoReport = 1) + expect_true(origFileSize < file.size( + file.path( + Sys.getenv("R_RAP_CONFIG_PATH"), + "autoReport.yml" + ) + )) + # get newly created edit button id (from last entry in table) + # and test it by entry being removed from table + btnRaw <- autoReport$tab[dim(autoReport$tab)[1], ]$Endre + editButton <- rvest::read_html(btnRaw) %>% + rvest::html_element("button") %>% + rvest::html_attr("id") + repsBefore <- dim(autoReport$tab)[1] + session$setInputs(edit_button = editButton) + repsAfter <- dim(autoReport$tab)[1] + expect_true(repsAfter == (repsBefore - 1)) + # then, true deletion (after adding one more time) + session$setInputs(makeAutoReport = 2) + expect_true(repsBefore == dim(autoReport$tab)[1]) + btnRaw <- autoReport$tab[dim(autoReport$tab)[1], ]$Slett + delButton <- rvest::read_html(btnRaw) %>% + rvest::html_element("button") %>% + rvest::html_attr("id") + session$setInputs(del_button = delButton) + repsAfter <- dim(autoReport$tab)[1] + expect_true(repsAfter == (repsBefore - 1)) + } + ) + }) + + test_that("add email button is not created if email is not valid", { + shiny::testServer( + autoReportServer2, + args = list( + registryName = registryName, type = type, + org = shiny::reactive(100082), + reports = reports, orgs = orgs, user = user + ), + { + session$setInputs(email = "invalid@email-format") + expect_true(is.null(output$editEmail)) + session$setInputs(email = "invalid@email-format.o") + expect_true(is.null(output$editEmail)) + session$setInputs(email = "invalid.email-format.on") + expect_true(is.null(output$editEmail)) + } + ) + }) + + test_that("no submit button is provided when module is not eligible", { + shiny::testServer( + autoReportServer2, + args = list( + registryName = registryName, type = "subscription", + reports = reports, orgs = orgs, eligible = FALSE, user = user + ), + { + session$setInputs(email = "valid.email@format.no") + expect_true(is.null(output$makeAutoReport)) + } + ) + }) + + test_that("tabel is replaced by message when no reports listed", { + file.remove(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "autoReport.yml")) + file.create(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "autoReport.yml")) + shiny::testServer( + autoReportServer2, + args = list( + registryName = registryName, type = type, + org = shiny::reactive(100082), + reports = reports, orgs = orgs, user = user + ), + { + session$flushReact() + expect_true(dim(autoReport$tab)[1] == 0) + } + ) + }) + } +) + # Restore instance Sys.setenv(R_RAP_CONFIG_PATH = currentConfigPath) diff --git a/tests/testthat/test-moduleNavbarWidget.R b/tests/testthat/test-moduleNavbarWidget.R index cf43bbf9..1ddce65c 100644 --- a/tests/testthat/test-moduleNavbarWidget.R +++ b/tests/testthat/test-moduleNavbarWidget.R @@ -37,6 +37,42 @@ test_that("test app returns an app object", { }) +## new widget for shinyproxy container instances +file.copy( + system.file("extdata/accesstree.json", package = "rapbase"), + Sys.getenv("R_RAP_CONFIG_PATH") +) + +with_envvar( + new = c( + "R_RAP_INSTANCE" = "QAC", + "SHINYPROXY_USERNAME" = "ttesterc", + "SHINYPROXY_USERGROUPS" = "rapbase,rapbase,utils,utils", + "USERORGID" = "[1, 2, 3, 4]", + "USERFULLNAME" = "Tore Tester Container" + ), + code = { + + test_that("shinyproxy-like module navbar widget server returns output", { + shiny::testServer(navbarWidgetServer2, args = list( + orgName = registryName, + caller = "rapbase" + ), { + expect_equal(output$name, "Tore Tester Container") + expect_equal(class(output$affiliation), "character") + session$setInputs(userInfo = 1) + session$setInputs(selectOrganization = 1, unit = 1) + expect_equal(rv$name, "ttesterc") + expect_equal(rv$fullName, "Tore Tester Container") + expect_equal(rv$group, "rapbase") + expect_equal(rv$unit, "1") + expect_equal(rv$org, "100082") + expect_equal(rv$role, "LU") + }) + }) + } +) + # Restore instance Sys.setenv(R_RAP_INSTANCE = currentInstance) Sys.setenv(R_RAP_CONFIG_PATH = currentConfigPath) From 8b97d248eaed485f468eb85837479e1495d83412 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 11 Oct 2022 14:52:43 +0200 Subject: [PATCH 30/79] remove debugging --- tests/testthat/test-moduleAutoReport.R | 1 - 1 file changed, 1 deletion(-) diff --git a/tests/testthat/test-moduleAutoReport.R b/tests/testthat/test-moduleAutoReport.R index 24aedbba..78584af7 100644 --- a/tests/testthat/test-moduleAutoReport.R +++ b/tests/testthat/test-moduleAutoReport.R @@ -341,7 +341,6 @@ with_envvar( type <- "subscription" user <- userAttribute("rapbase", unit = 1) for (n in names(user)) { - print(user[[n]]) user[[n]] <- shiny::reactiveVal(user[[n]]) } From f170b3db246c88050a18f031b20e1e575bb3475d Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 20 Oct 2022 10:49:45 +0200 Subject: [PATCH 31/79] emulate falk rap app type --- R/userAttribute.R | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/R/userAttribute.R b/R/userAttribute.R index c9055193..c75bfbd9 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -234,6 +234,16 @@ userAttribute <- function(group, unit = NULL) { )) } + ### DUE TO CURRENT LIMITATIONS TO FALK (currently application type OQR) ### + # HARD CODED ROLES HAVE TO BE MAPPED TO SHINYPROXY APPLICATION PRIVILEGES # + # THEREFORE, THE NEXT SECTION IS TO BE REMOVED ONCE A PROPER RAPPORTEKET # + # APPLICATION TYPE IS IN PLACE. # + ### ------------------- REMOVE THE SECTION BELOW! ------------------------- # + groups[groups == "LU"] <- "falkdemo" + groups[groups == "LC"] <- "ablanor" + groups[groups == "SC"] <- "rapadm" + + # NB Anticipate that element positions in vectors do correspond! ## filter by this group units <- units[groups == group] From 7710048c41a7bb8812a51d20f11d6f59edba11c2 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 8 Nov 2022 14:12:11 +0100 Subject: [PATCH 32/79] lint --- R/userAttribute.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/userAttribute.R b/R/userAttribute.R index c75bfbd9..12cd91e6 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -227,7 +227,7 @@ userAttribute <- function(group, unit = NULL) { ) ) - if(length(units) != length(groups)) { + if (length(units) != length(groups)) { stop(paste( "Vectors obtained from SHINYPROXY_USERGROUPS and USERORGID are of", "different lengths. Hence, correspondence cannot be anticipated." @@ -250,7 +250,7 @@ userAttribute <- function(group, unit = NULL) { groups <- groups[groups == group] ## restrict when unit is provided - if(!is.null(unit)) { + if (!is.null(unit)) { groups <- groups[units == unit] units <- units[units == unit] } From dd0824dafd2542765a8d030a818f9ffed76689ab Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 1 Dec 2022 08:33:45 +0100 Subject: [PATCH 33/79] sync with poc branch --- R/stagingData.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 38bbff1d..2f11c55e 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -148,8 +148,8 @@ cleanStagingData <- function(eolAge, dryRun = TRUE) { paste( "Function invoked in dry run mode and none of the returned files\n", "will be deleted.\n", - "To delete the files please re-run this function with the dryRun\n", - "argument set to 'TRUE'. Godspeed!" + "To delete the files please contemplate and re-run this function\n", + "with the dryRun argument set to 'FALSE'. Godspeed!" ) ) fDelete From 6e9aa6b8757a1b140f1bcdd212873ba42eb3ca46 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 2 Dec 2022 15:00:46 +0100 Subject: [PATCH 34/79] just a starter --- R/stagingData.R | 113 +++++++++++++++++++++++++++++- inst/createStagingDb.sql | 6 ++ inst/createStagingTab.sql | 8 +++ inst/rapbaseConfig.yml | 5 ++ man/stagingData.Rd | 6 ++ tests/testthat/test-stagingData.R | 91 +++++++++++++++++++++++- 6 files changed, 225 insertions(+), 4 deletions(-) create mode 100644 inst/createStagingDb.sql create mode 100644 inst/createStagingTab.sql diff --git a/R/stagingData.R b/R/stagingData.R index 2f11c55e..ad0ab076 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -43,7 +43,8 @@ #' #' @name stagingData #' @aliases listStagingData mtimeStagingData saveStagingData loadStagingData -#' deleteStagingData cleanStagingData pathStagingData +#' deleteStagingData cleanStagingData pathStagingData dbStagingData +#' dbStagingConnection #' #' @examples #' ## Prep test data @@ -92,9 +93,42 @@ mtimeStagingData <- function(registryName, #' @export saveStagingData <- function(registryName, dataName, data, dir = Sys.getenv("R_RAP_CONFIG_PATH")) { - path <- pathStagingData(registryName, dir) + conf <- getConfig("rapbaseConfig.yml")$r$staging + + if (conf$target == "file") { + path <- pathStagingData(registryName, dir) + readr::write_rds(data, file.path(path, dataName)) + } + + if (conf$target == "db") { + dbStagingData(conf$key) + blob <- memCompress( + serialize(data, connection = NULL), + type = "bzip2" + ) + + df <- data.frame( + registry = registryName, + name = dataName, + data = blob::as.blob(blob) + ) + + cleanQuery <- paste0( + "DELETE FROM data WHERE registry = '", + registryName, + "' AND name = '", + dataName, + "'" + ) - readr::write_rds(data, file.path(path, dataName)) + con <- dbStagingConnection(key = conf$key) + RMariaDB::dbExecute(con, cleanQuery) + RMariaDB::dbAppendTable(con, "data", df) + con <- dbStagingConnection(con = con) + + return(invisible(data)) + + } } #' @rdname stagingData @@ -173,3 +207,76 @@ pathStagingData <- function(registryName, dir) { path } + +#' @rdname stagingData +dbStagingData <- function(key, drop = FALSE) { + + conf <- getConfig()[[key]] + if (is.null(conf)) { + stop(paste("There is no configuration corresponding to key", key)) + } + if (drop) { + query <- paste("DROP DATABASE", conf$name) + msg <- paste0("Database '", conf$name, "' deleted.") + } else { + query <- c( + sprintf( + readLines(system.file("createStagingDb.sql", package = "rapbase")), + conf$name + ), + paste0( + readLines(system.file("createStagingTab.sql", package = "rapbase")), + collapse = "\n" + ) + ) + msg <- paste0("Database '", conf$name, "exists.") + } + + con <- dbStagingConnection(key = key, init = TRUE) + for (q in query) { + tmp <- RMariaDB::dbExecute(con, q) + } + + con <- dbStagingConnection(con = con) + + invisible(msg) +} + +#' @rdname stagingData +dbStagingConnection <- function(key = NULL, con = NULL, init = FALSE) { + + if (inherits(con, "DBIConnection")) { + con <- DBI::dbDisconnect(con) + con <- NULL + return(invisible(con)) + } + + if (!is.null(key)) { + conf <- getConfig()[[key]] + if (is.null(conf)) { + stop( + paste0( + "Could not connect to database because there is no configuration ", + "corresponding to key '", key,"'. Please check key and/or ", + "configuration." + ) + ) + } + if (init) { + dbname <- NULL + } else { + dbname <- conf$name + } + drv <- RMariaDB::MariaDB() + con <- RMariaDB::dbConnect( + drv, + dbname, + host = conf$host, + user = conf$user, + password = conf$pass + ) + return(con) + } else { + stop("Either a key or a valid database connection object must be provided.") + } +} diff --git a/inst/createStagingDb.sql b/inst/createStagingDb.sql new file mode 100644 index 00000000..47330a5b --- /dev/null +++ b/inst/createStagingDb.sql @@ -0,0 +1,6 @@ +SET NAMES utf8; +SET time_zone = '+00:00'; +SET foreign_key_checks = 0; +SET sql_mode = 'NO_AUTO_VALUE_ON_ZERO'; +CREATE DATABASE IF NOT EXISTS `%s` /*!40100 DEFAULT CHARACTER SET utf8 COLLATE utf8_danish_ci */; +USE %s; diff --git a/inst/createStagingTab.sql b/inst/createStagingTab.sql new file mode 100644 index 00000000..daf4512d --- /dev/null +++ b/inst/createStagingTab.sql @@ -0,0 +1,8 @@ +CREATE TABLE IF NOT EXISTS `data` ( + `id` bigint unsigned NOT NULL AUTO_INCREMENT, + `mtime` timestamp DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP, + `registry` varchar(255) NOT NULL COLLATE utf8_danish_ci, + `name` varchar(255) NOT NULL COLLATE utf8_danish_ci, + `data` longblob, + PRIMARY KEY (`id`) +) ENGINE=InnoDB DEFAULT CHARSET=utf8 COLLATE=utf8_danish_ci; diff --git a/inst/rapbaseConfig.yml b/inst/rapbaseConfig.yml index 03bf58dc..65f1d2ba 100644 --- a/inst/rapbaseConfig.yml +++ b/inst/rapbaseConfig.yml @@ -20,6 +20,11 @@ r : target: file key: autoreport + # Staging data + staging: + target: file + key: staging + # User data for testing purposes testUser : user : ttester diff --git a/man/stagingData.Rd b/man/stagingData.Rd index e457794f..c2341ddb 100644 --- a/man/stagingData.Rd +++ b/man/stagingData.Rd @@ -9,6 +9,8 @@ \alias{deleteStagingData} \alias{cleanStagingData} \alias{pathStagingData} +\alias{dbStagingData} +\alias{dbStagingConnection} \title{Staging data functions} \usage{ listStagingData(registryName, dir = Sys.getenv("R_RAP_CONFIG_PATH")) @@ -33,6 +35,10 @@ deleteStagingData( cleanStagingData(eolAge, dryRun = TRUE) pathStagingData(registryName, dir) + +dbStagingData(key, drop = FALSE) + +dbStagingConnection(key = NULL, con = NULL) } \arguments{ \item{registryName}{Character string providing the registry name.} diff --git a/tests/testthat/test-stagingData.R b/tests/testthat/test-stagingData.R index b0ba984d..3268ed62 100644 --- a/tests/testthat/test-stagingData.R +++ b/tests/testthat/test-stagingData.R @@ -13,7 +13,18 @@ testPath <- file.path( ) testFile <- file.path(testPath, dataName) -test_that("staging cannot commence if paret directory does not exist", { +# test config for file backend +test_config <- paste0( + "r:", + "\n staging: ", + "\n target: file", + "\n key: staging\n" +) +cf <- file(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "rapbaseConfig.yml")) +writeLines(test_config, cf) +close(cf) + +test_that("staging cannot commence if parent directory does not exist", { expect_error(pathStagingData(registryName, dir = "imaginaryDir")) expect_error( saveStagingData(registryName, "testData", d, dir = "imaginaryDir") @@ -69,10 +80,88 @@ test_that("a global clean of staging data can be performed (also dry run)", { expect_false(file.exists(testFile)) }) +# clean up config for file backend +unlink(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "rapbaseConfig.yml")) + test_that("a global clean of staging data will stop if no parent directory", { Sys.unsetenv("R_RAP_CONFIG_PATH") expect_error(cleanStagingData(0)) }) +# Test with db as backend +Sys.setenv(R_RAP_CONFIG_PATH = tempdir()) + +# Database infrastructure is only available at GA and our own dev env. +# Tests running on other environments should be skipped +checkDb <- function(is_test_that = TRUE) { + if (Sys.getenv("R_RAP_INSTANCE") == "DEV") { + NULL + } else if (Sys.getenv("GITHUB_ACTIONS_RUN_DB_UNIT_TESTS") == "true") { + NULL + } else { + if (is_test_that) { + testthat::skip("Possible lack of database infrastructure") + } else { + 1 + } + } +} + +test_that("env vars needed for db testing is present", { + checkDb() + expect_true("DB_HOST" %in% names(Sys.getenv())) + expect_true("DB_USER" %in% names(Sys.getenv())) + expect_true("DB_PASS" %in% names(Sys.getenv())) +}) + +# make temporary config +test_config <- paste0( + "staging:", + "\n host : ", Sys.getenv("DB_HOST"), + "\n name : staging", + "\n user : ", Sys.getenv("DB_USER"), + "\n pass : ", Sys.getenv("DB_PASS"), + "\n disp : ephemaralUnitTesting\n" +) +cf <- file(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "dbConfig.yml")) +writeLines(test_config, cf) +close(cf) + +test_config <- paste0( + "r:", + "\n staging: ", + "\n target: db", + "\n key: staging\n" +) +cf <- file(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "rapbaseConfig.yml")) +writeLines(test_config, cf) +close(cf) + +if (is.null(checkDb(is_test_that = FALSE))) { + dbStagingData("staging") +} + +test_that("Error is returned when key cannot be found in config", { + expect_error(dbStagingData("wrongEntry")) +}) + +test_that("A db connection object can be opened and closed", { + con <- dbStagingConnection(key = "staging") + expect_true(inherits(con, "DBIConnection")) + con <- dbStagingConnection(con = con) + expect_true(is.null(con)) +}) + +test_that("Data can be staged", { + d0 <- saveStagingData(registryName, "testData", d) + expect_true(identical(d, d0)) +}) + +if (is.null(checkDb(is_test_that = FALSE))) { + dbStagingData("staging", drop = TRUE) +} + # Restore environment +unlink(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "rapbaseConfig.yml")) +unlink(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "dbConfig.yml")) Sys.setenv(R_RAP_CONFIG_PATH = currentConfigPath) From 140f3d94055314d9d00832a61ed06e1689fa1a0b Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 5 Dec 2022 14:50:47 +0100 Subject: [PATCH 35/79] new pkg --- DESCRIPTION | 1 + 1 file changed, 1 insertion(+) diff --git a/DESCRIPTION b/DESCRIPTION index 0e55678e..eca2f2ec 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,6 +25,7 @@ Depends: R (>= 3.5.0) Imports: base64enc, + blob, bookdown, DBI, digest, From 6999add7b13a826097c5890b0019da2de7d2a062 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 5 Dec 2022 14:56:02 +0100 Subject: [PATCH 36/79] early return --- R/stagingData.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/R/stagingData.R b/R/stagingData.R index ad0ab076..7c373459 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -97,7 +97,11 @@ saveStagingData <- function(registryName, dataName, data, if (conf$target == "file") { path <- pathStagingData(registryName, dir) - readr::write_rds(data, file.path(path, dataName)) + return( + invisible( + readr::write_rds(data, file.path(path, dataName)) + ) + ) } if (conf$target == "db") { From 3026bd81f5fee53e9799984c28c6deca2621994d Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 5 Dec 2022 15:31:59 +0100 Subject: [PATCH 37/79] listing also from db backend --- R/stagingData.R | 24 ++++++++++++++++++++++-- tests/testthat/test-stagingData.R | 8 +++++++- 2 files changed, 29 insertions(+), 3 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 7c373459..1c390b2e 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -70,9 +70,29 @@ NULL #' @export listStagingData <- function(registryName, dir = Sys.getenv("R_RAP_CONFIG_PATH")) { - path <- pathStagingData(registryName, dir) - list.files(path) + conf <- getConfig("rapbaseConfig.yml")$r$staging + + if (conf$target == "file") { + path <- pathStagingData(registryName, dir) + + return(list.files(path)) + } + + if (conf$target == "db") { + query <- paste0( + "SELECT name FROM data WHERE registry = ?;" + ) + params <- list(registryName) + con <- dbStagingConnection(key = conf$key) + rs <- RMariaDB::dbSendQuery(con, query) + RMariaDB::dbBind(rs, params) + df <- RMariaDB::dbFetch(rs) + RMariaDB::dbClearResult(rs) + con <- dbStagingConnection(con = con) + + return(df$name) + } } #' @rdname stagingData diff --git a/tests/testthat/test-stagingData.R b/tests/testthat/test-stagingData.R index 3268ed62..50a74464 100644 --- a/tests/testthat/test-stagingData.R +++ b/tests/testthat/test-stagingData.R @@ -152,11 +152,17 @@ test_that("A db connection object can be opened and closed", { expect_true(is.null(con)) }) -test_that("Data can be staged", { +test_that("Data can be staged with db backend", { d0 <- saveStagingData(registryName, "testData", d) expect_true(identical(d, d0)) }) +test_that("staging files can be listed from db backend", { + v <- listStagingData(registryName) + expect_equal(class(v), "character") + expect_identical(v, "testData") +}) + if (is.null(checkDb(is_test_that = FALSE))) { dbStagingData("staging", drop = TRUE) } From 7fdef2f3b873fa97e0ac355c1964ee4f1ae5e443 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 6 Dec 2022 09:44:16 +0100 Subject: [PATCH 38/79] general db process --- R/stagingData.R | 58 +++++++++++++++++++++++----------------------- man/stagingData.Rd | 5 +++- 2 files changed, 33 insertions(+), 30 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 1c390b2e..3b7d1c12 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -44,7 +44,7 @@ #' @name stagingData #' @aliases listStagingData mtimeStagingData saveStagingData loadStagingData #' deleteStagingData cleanStagingData pathStagingData dbStagingData -#' dbStagingConnection +#' dbStagingConnection dbStagingProcess #' #' @examples #' ## Prep test data @@ -80,16 +80,9 @@ listStagingData <- function(registryName, } if (conf$target == "db") { - query <- paste0( - "SELECT name FROM data WHERE registry = ?;" - ) + query <- "SELECT name FROM data WHERE registry = ?;" params <- list(registryName) - con <- dbStagingConnection(key = conf$key) - rs <- RMariaDB::dbSendQuery(con, query) - RMariaDB::dbBind(rs, params) - df <- RMariaDB::dbFetch(rs) - RMariaDB::dbClearResult(rs) - con <- dbStagingConnection(con = con) + df <- dbStagingProcess(conf$key, query, params) return(df$name) } @@ -126,32 +119,22 @@ saveStagingData <- function(registryName, dataName, data, if (conf$target == "db") { dbStagingData(conf$key) - blob <- memCompress( + b <- memCompress( serialize(data, connection = NULL), type = "bzip2" ) - df <- data.frame( - registry = registryName, - name = dataName, - data = blob::as.blob(blob) - ) - - cleanQuery <- paste0( - "DELETE FROM data WHERE registry = '", - registryName, - "' AND name = '", - dataName, - "'" - ) + # remove any existing registry data with same data name + query <- "DELETE FROM data WHERE registry = ? AND name = ?;" + params <- list(registryName, dataName) + df <- dbStagingProcess(conf$key, query, params, statement = TRUE) - con <- dbStagingConnection(key = conf$key) - RMariaDB::dbExecute(con, cleanQuery) - RMariaDB::dbAppendTable(con, "data", df) - con <- dbStagingConnection(con = con) + # insert new data + query <- "INSERT INTO data (registry, name, data) VALUES (?, ?, ?);" + params <- list(registryName, dataName, blob::as_blob(b)) + df <- dbStagingProcess(conf$key, query, params, statement = TRUE) return(invisible(data)) - } } @@ -304,3 +287,20 @@ dbStagingConnection <- function(key = NULL, con = NULL, init = FALSE) { stop("Either a key or a valid database connection object must be provided.") } } + +#' @rdname stagingData +dbStagingProcess <- function(key, query, params, statement = FALSE) { + + con <- dbStagingConnection(key) + if (statement) { + df <- RMariaDB::dbExecute(con, query, params) + } else { + rs <- RMariaDB::dbSendQuery(con, query) + RMariaDB::dbBind(rs, params) + df <- RMariaDB::dbFetch(rs) + RMariaDB::dbClearResult(rs) + } + con <- dbStagingConnection(con = con) + + df +} \ No newline at end of file diff --git a/man/stagingData.Rd b/man/stagingData.Rd index c2341ddb..a074850c 100644 --- a/man/stagingData.Rd +++ b/man/stagingData.Rd @@ -11,6 +11,7 @@ \alias{pathStagingData} \alias{dbStagingData} \alias{dbStagingConnection} +\alias{dbStagingProcess} \title{Staging data functions} \usage{ listStagingData(registryName, dir = Sys.getenv("R_RAP_CONFIG_PATH")) @@ -38,7 +39,9 @@ pathStagingData(registryName, dir) dbStagingData(key, drop = FALSE) -dbStagingConnection(key = NULL, con = NULL) +dbStagingConnection(key = NULL, con = NULL, init = FALSE) + +dbStagingProcess(key, query, params, statement = FALSE) } \arguments{ \item{registryName}{Character string providing the registry name.} From fdb18362a365c7b2edc0942ef561e839048e3290 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 6 Dec 2022 11:26:10 +0100 Subject: [PATCH 39/79] time stamp from db --- R/stagingData.R | 22 +++++++++++++++++----- tests/testthat/test-stagingData.R | 4 ++++ 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 3b7d1c12..c7415e47 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -92,13 +92,25 @@ listStagingData <- function(registryName, #' @export mtimeStagingData <- function(registryName, dir = Sys.getenv("R_RAP_CONFIG_PATH")) { - parentPath <- "stagingData" - path <- file.path(dir, parentPath, registryName) - f <- normalizePath(list.files(path, recursive = TRUE, full.names = TRUE)) - mtime <- file.mtime(f) - names(mtime) <- basename(f) + conf <- getConfig("rapbaseConfig.yml")$r$staging + + if (conf$target == "file") { + parentPath <- "stagingData" + path <- file.path(dir, parentPath, registryName) + f <- normalizePath(list.files(path, recursive = TRUE, full.names = TRUE)) + mtime <- file.mtime(f) + + names(mtime) <- basename(f) + } + if (conf$target == "db") { + query <- "SELECT mtime, name FROM data WHERE registry = ?;" + params <- list(registryName) + df <- dbStagingProcess(conf$key, query, params) + mtime <- as.POSIXct(df$mtime) + names(mtime) <- df$name + } mtime } diff --git a/tests/testthat/test-stagingData.R b/tests/testthat/test-stagingData.R index 50a74464..98442f6f 100644 --- a/tests/testthat/test-stagingData.R +++ b/tests/testthat/test-stagingData.R @@ -163,6 +163,10 @@ test_that("staging files can be listed from db backend", { expect_identical(v, "testData") }) +test_that("modification time of stagin data in db can be obtained", { + expect_true("POSIXct" %in% class(mtimeStagingData(registryName))) +}) + if (is.null(checkDb(is_test_that = FALSE))) { dbStagingData("staging", drop = TRUE) } From 3b7434cb40ccf9c71ef36152b20ec680909a3e6d Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 6 Dec 2022 14:41:02 +0100 Subject: [PATCH 40/79] staging db load and delete --- R/stagingData.R | 85 +++++++++++++++++++++++-------- man/stagingData.Rd | 5 +- tests/testthat/test-stagingData.R | 30 ++++++++++- 3 files changed, 96 insertions(+), 24 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index c7415e47..9fb38056 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -27,8 +27,9 @@ #' files for the given registry (\code{registryName}). #' \item \code{mtimeStagingData()} returns a staging file-named POSIXct vector #' of modification times for the given registry (\code{registryName}). -#' \item \code{saveStagingData()} returns the data object (\code{data}), -#' invisibly. +#' \item \code{saveStagingData()} when successful returns the data object +#' (\code{data}), invisibly. If saving fails a warning is issued and the +#' function returns FALSE. #' \item \code{loadStagingData()} returns the data object corresponding to #' the name given upon saving (\code{dataName}). If the requested data set #' for loading does not exist the function returns FALSE. @@ -136,17 +137,21 @@ saveStagingData <- function(registryName, dataName, data, type = "bzip2" ) - # remove any existing registry data with same data name + # remove any existing registry data with same data name (should never fail) query <- "DELETE FROM data WHERE registry = ? AND name = ?;" params <- list(registryName, dataName) - df <- dbStagingProcess(conf$key, query, params, statement = TRUE) + d <- dbStagingProcess(conf$key, query, params, statement = TRUE) - # insert new data + # insert new data (can fail, but hard to test...) query <- "INSERT INTO data (registry, name, data) VALUES (?, ?, ?);" params <- list(registryName, dataName, blob::as_blob(b)) - df <- dbStagingProcess(conf$key, query, params, statement = TRUE) - - return(invisible(data)) + d <- dbStagingProcess(conf$key, query, params, statement = TRUE) + if (d > 0) { + return(invisible(data)) + } else { + warning(paste0("The data set '", dataName, "' could not be saved!")) + return(FALSE) + } } } @@ -154,29 +159,67 @@ saveStagingData <- function(registryName, dataName, data, #' @export loadStagingData <- function(registryName, dataName, dir = Sys.getenv("R_RAP_CONFIG_PATH")) { - path <- pathStagingData(registryName, dir) - filePath <- file.path(path, dataName) - if (file.exists(filePath)) { - readr::read_rds(filePath) - } else { - FALSE + conf <- getConfig("rapbaseConfig.yml")$r$staging + + if (conf$target == "file") { + path <- pathStagingData(registryName, dir) + filePath <- file.path(path, dataName) + + if (file.exists(filePath)) { + data <- readr::read_rds(filePath) + } else { + data <- FALSE + } + } + + if (conf$target == "db") { + query <- "SELECT data FROM data WHERE registry = ? AND name = ?;" + params <- list(registryName, dataName) + df <- dbStagingProcess(conf$key, query, params) + if (length(df$data) == 0) { + data <- FALSE + } else { + data <- df$data[[1]] %>% + memDecompress(type = "bzip2") %>% + unserialize() + } } + + data } #' @rdname stagingData #' @export deleteStagingData <- function(registryName, dataName, dir = Sys.getenv("R_RAP_CONFIG_PATH")) { - path <- pathStagingData(registryName, dir) - filePath <- file.path(path, dataName) - if (file.exists(filePath)) { - file.remove(filePath) - TRUE - } else { - FALSE + conf <- getConfig("rapbaseConfig.yml")$r$staging + + if (conf$target == "file") { + path <- pathStagingData(registryName, dir) + filePath <- file.path(path, dataName) + + if (file.exists(filePath)) { + file.remove(filePath) + isDelete <- TRUE + } else { + isDelete <- FALSE + } } + + if (conf$target == "db") { + query <- "DELETE FROM data WHERE registry = ? AND name = ?;" + params <- list(registryName, dataName) + d <- dbStagingProcess(conf$key, query, params, statement = TRUE) + if (d > 0) { + isDelete <- TRUE + } else { + isDelete <- FALSE + } + } + + isDelete } #' @rdname stagingData diff --git a/man/stagingData.Rd b/man/stagingData.Rd index a074850c..d34af1fb 100644 --- a/man/stagingData.Rd +++ b/man/stagingData.Rd @@ -67,8 +67,9 @@ destructive) mode.} files for the given registry (\code{registryName}). \item \code{mtimeStagingData()} returns a staging file-named POSIXct vector of modification times for the given registry (\code{registryName}). - \item \code{saveStagingData()} returns the data object (\code{data}), - invisibly. + \item \code{saveStagingData()} when successful returns the data object + (\code{data}), invisibly. If saving fails a warning is issued and the + function returns FALSE. \item \code{loadStagingData()} returns the data object corresponding to the name given upon saving (\code{dataName}). If the requested data set for loading does not exist the function returns FALSE. diff --git a/tests/testthat/test-stagingData.R b/tests/testthat/test-stagingData.R index 98442f6f..be87e6b4 100644 --- a/tests/testthat/test-stagingData.R +++ b/tests/testthat/test-stagingData.R @@ -61,7 +61,7 @@ test_that("loading none-existing data returns false", { expect_false(loadStagingData(registryName, "imaginaryDataSet")) }) -test_that("deleting a none-existing file returns FALE", { +test_that("deleting a none-existing file returns FALSE", { expect_false(deleteStagingData(registryName, "imaginaryDataSet")) }) @@ -167,6 +167,34 @@ test_that("modification time of stagin data in db can be obtained", { expect_true("POSIXct" %in% class(mtimeStagingData(registryName))) }) +test_that("retrieval of none existing data returns FALSE", { + expect_false(loadStagingData(registryName, "noSuchDataSet")) +}) + +test_that("data can be retrieved from staging db", { + #print(loadStagingData(registryName, dataName)) + expect_equal(loadStagingData(registryName, dataName), d) +}) + +test_that("deleting a none-existing dataset from db returns FALSE", { + expect_false(deleteStagingData(registryName, "imaginaryDataSet")) +}) + +test_that("a dataset can be deleted from db", { + expect_true(deleteStagingData(registryName, dataName)) + expect_false(loadStagingData(registryName, dataName)) +}) + +test_that("a global clean of db staging data can be performed (also dry run)", { + expect_equal(saveStagingData(registryName, dataName, d), d) + expect_true(file.exists(testFile)) + expect_message(cleanStagingData(0)) + expect_equal(class(cleanStagingData(0)), "character") + expect_true(file.exists(testFile)) + expect_invisible(cleanStagingData(0, dryRun = FALSE)) + expect_false(file.exists(testFile)) +}) + if (is.null(checkDb(is_test_that = FALSE))) { dbStagingData("staging", drop = TRUE) } From c1464c0734c7066b7df9e1e37770b2c0b502864d Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 6 Dec 2022 15:45:11 +0100 Subject: [PATCH 41/79] cleaning staging data in db --- R/stagingData.R | 48 ++++++++++++++++++++++--------- tests/testthat/test-stagingData.R | 6 ++-- 2 files changed, 37 insertions(+), 17 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 9fb38056..243549f1 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -227,31 +227,51 @@ deleteStagingData <- function(registryName, dataName, cleanStagingData <- function(eolAge, dryRun = TRUE) { if (Sys.getenv("R_RAP_CONFIG_PATH") == "") { stop(paste( - "Got no path to staging data. No data will be deleted.", + "No data store provided. Hence, no data will be deleted.", "Exiting." )) } - dir <- Sys.getenv("R_RAP_CONFIG_PATH") - parentPath <- "stagingData" - path <- file.path(dir, parentPath) - f <- normalizePath(list.files(path, recursive = TRUE, full.names = TRUE)) - fAge <- as.numeric(Sys.time()) - as.numeric(file.mtime(f)) - fDelete <- f[fAge > eolAge] + conf <- getConfig("rapbaseConfig.yml")$r$staging + + if (conf$target == "file") { + dir <- Sys.getenv("R_RAP_CONFIG_PATH") + parentPath <- "stagingData" + path <- file.path(dir, parentPath) + f <- normalizePath(list.files(path, recursive = TRUE, full.names = TRUE)) + fAge <- as.numeric(Sys.time()) - as.numeric(file.mtime(f)) + deleteDataset <- f[fAge > eolAge] + } + + if (conf$target == "db") { + eolTime <- Sys.time() - eolAge + query <- paste0( + "SELECT registry, name FROM data WHERE mtime < ? ORDER BY registry, name;" + ) + params <- list(eolTime) + df <- dbStagingProcess(conf$key, query, params) + deleteDataset <- paste0(df$registry, ": ", df$name) + } if (dryRun) { message( paste( - "Function invoked in dry run mode and none of the returned files\n", - "will be deleted.\n", - "To delete the files please contemplate and re-run this function\n", + "Function invoked in dry run mode and none of the returned staging\n", + "data sets will be deleted.\n", + "To delete for real, please contemplate and re-run this function\n", "with the dryRun argument set to 'FALSE'. Godspeed!" ) ) - fDelete + deleteDataset } else { - file.remove(fDelete) - invisible(fDelete) + if (conf$target == "file") { + file.remove(deleteDataset) + } + if (conf$target == "db") { + query <- "DELETE FROM data WHERE mtime < ?;" + d <- dbStagingProcess(conf$key, query, params, statement = TRUE) + } + invisible(deleteDataset) } } @@ -344,7 +364,7 @@ dbStagingConnection <- function(key = NULL, con = NULL, init = FALSE) { } #' @rdname stagingData -dbStagingProcess <- function(key, query, params, statement = FALSE) { +dbStagingProcess <- function(key, query, params = list(), statement = FALSE) { con <- dbStagingConnection(key) if (statement) { diff --git a/tests/testthat/test-stagingData.R b/tests/testthat/test-stagingData.R index be87e6b4..8fc08742 100644 --- a/tests/testthat/test-stagingData.R +++ b/tests/testthat/test-stagingData.R @@ -187,12 +187,12 @@ test_that("a dataset can be deleted from db", { test_that("a global clean of db staging data can be performed (also dry run)", { expect_equal(saveStagingData(registryName, dataName, d), d) - expect_true(file.exists(testFile)) + expect_identical(listStagingData(registryName), dataName) expect_message(cleanStagingData(0)) expect_equal(class(cleanStagingData(0)), "character") - expect_true(file.exists(testFile)) + expect_identical(listStagingData(registryName), dataName) expect_invisible(cleanStagingData(0, dryRun = FALSE)) - expect_false(file.exists(testFile)) + expect_false(loadStagingData(registryName, dataName)) }) if (is.null(checkDb(is_test_that = FALSE))) { From 3923a3c1b4a6d079a0fe115d6d909d95899d0494 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Wed, 7 Dec 2022 13:27:42 +0100 Subject: [PATCH 42/79] extending, error fixing and clean-up --- R/stagingData.R | 27 ++++++++++++++++-- man/stagingData.Rd | 5 +++- tests/testthat/test-stagingData.R | 46 +++++++++++++++++++++---------- 3 files changed, 61 insertions(+), 17 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 243549f1..301f1b8c 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -45,7 +45,7 @@ #' @name stagingData #' @aliases listStagingData mtimeStagingData saveStagingData loadStagingData #' deleteStagingData cleanStagingData pathStagingData dbStagingData -#' dbStagingConnection dbStagingProcess +#' dbStagingPrereq dbStagingConnection dbStagingProcess #' #' @examples #' ## Prep test data @@ -81,6 +81,7 @@ listStagingData <- function(registryName, } if (conf$target == "db") { + dbStagingPrereq(conf$key) query <- "SELECT name FROM data WHERE registry = ?;" params <- list(registryName) df <- dbStagingProcess(conf$key, query, params) @@ -106,6 +107,7 @@ mtimeStagingData <- function(registryName, } if (conf$target == "db") { + dbStagingPrereq(conf$key) query <- "SELECT mtime, name FROM data WHERE registry = ?;" params <- list(registryName) df <- dbStagingProcess(conf$key, query, params) @@ -131,7 +133,7 @@ saveStagingData <- function(registryName, dataName, data, } if (conf$target == "db") { - dbStagingData(conf$key) + dbStagingPrereq(conf$key) b <- memCompress( serialize(data, connection = NULL), type = "bzip2" @@ -174,6 +176,7 @@ loadStagingData <- function(registryName, dataName, } if (conf$target == "db") { + dbStagingPrereq(conf$key) query <- "SELECT data FROM data WHERE registry = ? AND name = ?;" params <- list(registryName, dataName) df <- dbStagingProcess(conf$key, query, params) @@ -209,6 +212,7 @@ deleteStagingData <- function(registryName, dataName, } if (conf$target == "db") { + dbStagingPrereq(conf$key) query <- "DELETE FROM data WHERE registry = ? AND name = ?;" params <- list(registryName, dataName) d <- dbStagingProcess(conf$key, query, params, statement = TRUE) @@ -244,6 +248,7 @@ cleanStagingData <- function(eolAge, dryRun = TRUE) { } if (conf$target == "db") { + dbStagingPrereq(conf$key) eolTime <- Sys.time() - eolAge query <- paste0( "SELECT registry, name FROM data WHERE mtime < ? ORDER BY registry, name;" @@ -324,6 +329,24 @@ dbStagingData <- function(key, drop = FALSE) { invisible(msg) } +#' @rdname stagingData +dbStagingPrereq <- function(key) { + + con <- dbStagingConnection(key, init = TRUE) + query <- "SHOW DATABASES LIKE 'staging';" + df <- RMariaDB::dbGetQuery(con, query) + # close and remove db connection + con <- dbStagingConnection(con = con) + if (length(df$Database) > 0) { + msg <- "You're good! Database for staging data already exists." + } else { + dbStagingData(key) + msg <- "Database for staging data was created." + } + + invisible(msg) +} + #' @rdname stagingData dbStagingConnection <- function(key = NULL, con = NULL, init = FALSE) { diff --git a/man/stagingData.Rd b/man/stagingData.Rd index d34af1fb..98a309d2 100644 --- a/man/stagingData.Rd +++ b/man/stagingData.Rd @@ -10,6 +10,7 @@ \alias{cleanStagingData} \alias{pathStagingData} \alias{dbStagingData} +\alias{dbStagingPrereq} \alias{dbStagingConnection} \alias{dbStagingProcess} \title{Staging data functions} @@ -39,9 +40,11 @@ pathStagingData(registryName, dir) dbStagingData(key, drop = FALSE) +dbStagingPrereq(key) + dbStagingConnection(key = NULL, con = NULL, init = FALSE) -dbStagingProcess(key, query, params, statement = FALSE) +dbStagingProcess(key, query, params = list(), statement = FALSE) } \arguments{ \item{registryName}{Character string providing the registry name.} diff --git a/tests/testthat/test-stagingData.R b/tests/testthat/test-stagingData.R index 8fc08742..ed44b72a 100644 --- a/tests/testthat/test-stagingData.R +++ b/tests/testthat/test-stagingData.R @@ -114,7 +114,17 @@ test_that("env vars needed for db testing is present", { expect_true("DB_PASS" %in% names(Sys.getenv())) }) -# make temporary config +test_config <- paste0( + "r:", + "\n staging: ", + "\n target: db", + "\n key: staging\n" +) +cf <- file(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "rapbaseConfig.yml")) +writeLines(test_config, cf) +close(cf) + +# make proper dbConfig test_config <- paste0( "staging:", "\n host : ", Sys.getenv("DB_HOST"), @@ -127,25 +137,27 @@ cf <- file(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "dbConfig.yml")) writeLines(test_config, cf) close(cf) -test_config <- paste0( - "r:", - "\n staging: ", - "\n target: db", - "\n key: staging\n" -) -cf <- file(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "rapbaseConfig.yml")) -writeLines(test_config, cf) -close(cf) +test_that("No connection provided when no key (or connection object) given", { + expect_error(dbStagingConnection(key = NULL, con = NULL)) +}) -if (is.null(checkDb(is_test_that = FALSE))) { - dbStagingData("staging") -} +test_that("No connection provided when insufficient config", { + checkDb() + expect_error(dbStagingConnection("unknown"), regexp = "Could not connect") +}) + +# make new staging database using prereq function +test_that("prereq creates database initially", { + checkDb() + expect_silent(dbStagingPrereq("staging")) +}) test_that("Error is returned when key cannot be found in config", { expect_error(dbStagingData("wrongEntry")) }) test_that("A db connection object can be opened and closed", { + checkDb() con <- dbStagingConnection(key = "staging") expect_true(inherits(con, "DBIConnection")) con <- dbStagingConnection(con = con) @@ -153,26 +165,30 @@ test_that("A db connection object can be opened and closed", { }) test_that("Data can be staged with db backend", { + checkDb() d0 <- saveStagingData(registryName, "testData", d) expect_true(identical(d, d0)) }) test_that("staging files can be listed from db backend", { + checkDb() v <- listStagingData(registryName) expect_equal(class(v), "character") expect_identical(v, "testData") }) test_that("modification time of stagin data in db can be obtained", { + checkDb() expect_true("POSIXct" %in% class(mtimeStagingData(registryName))) }) test_that("retrieval of none existing data returns FALSE", { + checkDb() expect_false(loadStagingData(registryName, "noSuchDataSet")) }) test_that("data can be retrieved from staging db", { - #print(loadStagingData(registryName, dataName)) + checkDb() expect_equal(loadStagingData(registryName, dataName), d) }) @@ -181,11 +197,13 @@ test_that("deleting a none-existing dataset from db returns FALSE", { }) test_that("a dataset can be deleted from db", { + checkDb() expect_true(deleteStagingData(registryName, dataName)) expect_false(loadStagingData(registryName, dataName)) }) test_that("a global clean of db staging data can be performed (also dry run)", { + checkDb() expect_equal(saveStagingData(registryName, dataName, d), d) expect_identical(listStagingData(registryName), dataName) expect_message(cleanStagingData(0)) From 1434ca103e57408ec52cf5e76c6503b8c2ea1dc8 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Wed, 7 Dec 2022 15:32:25 +0100 Subject: [PATCH 43/79] make sure test do not interfere with dev env --- tests/testthat/test-stagingData.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-stagingData.R b/tests/testthat/test-stagingData.R index ed44b72a..9e553276 100644 --- a/tests/testthat/test-stagingData.R +++ b/tests/testthat/test-stagingData.R @@ -128,7 +128,7 @@ close(cf) test_config <- paste0( "staging:", "\n host : ", Sys.getenv("DB_HOST"), - "\n name : staging", + "\n name : test_staging", "\n user : ", Sys.getenv("DB_USER"), "\n pass : ", Sys.getenv("DB_PASS"), "\n disp : ephemaralUnitTesting\n" From 2a6149d65b8729c6627966c012e881aefc05cf8b Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Wed, 7 Dec 2022 15:33:00 +0100 Subject: [PATCH 44/79] update docs, restructure later --- R/stagingData.R | 38 +++++++++++++++++++++++--------------- man/stagingData.Rd | 27 +++++++++++++++------------ 2 files changed, 38 insertions(+), 27 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 301f1b8c..0700a90c 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -6,36 +6,39 @@ #' must therefore be established within each registry that take staging data #' into use. #' -#' \code{cleanStagingData()} globally removes all staging data files older than -#' the end-of-life age provided. This is potentially a vastly destructive -#' function that should be used with great care. +#' \code{cleanStagingData()} globally removes all staging data with store date +#' prior to the end-of-life age provided. This is a vastly destructive function +#' that should be used with great care. #' #' @param registryName Character string providing the registry name. #' @param dataName Character string providing the data set name. #' @param data A data object such as a data.frame to be stored as #' \code{dataName}. #' @param dir Character string providing the path to where the staging data -#' directory resides. Default value is \code{Sys.getenv("R_RAP_CONFIG_PATH")}. -#' @param eolAge Numeric providing the staging file end-of-life age in seconds. -#' Based on the current time and the file modification time stamp staging files -#' older than \code{eolAge} will be identified as subject for removal. +#' directory resides in case of storage as files. Default value is +#' \code{Sys.getenv("R_RAP_CONFIG_PATH")}. +#' @param eolAge Numeric providing the staging data end-of-life age in seconds. +#' Based on the current time and the time of storage staging files +#' older than \code{eolAge} will be identified as subject for removal. #' @param dryRun Logical defining if function is to be run in dry (none -#' destructive) mode. +#' destructive) mode. #' #' @return \itemize{ #' \item \code{listStagingData()} returns a character vector of staging data -#' files for the given registry (\code{registryName}). -#' \item \code{mtimeStagingData()} returns a staging file-named POSIXct vector -#' of modification times for the given registry (\code{registryName}). +#' sets for the given registry (\code{registryName}). +#' \item \code{mtimeStagingData()} returns a staging data set named POSIXct +#' vector of modification times for the given registry +#' (\code{registryName}). #' \item \code{saveStagingData()} when successful returns the data object #' (\code{data}), invisibly. If saving fails a warning is issued and the #' function returns FALSE. #' \item \code{loadStagingData()} returns the data object corresponding to #' the name given upon saving (\code{dataName}). If the requested data set #' for loading does not exist the function returns FALSE. -#' \item \code{deleteStagingData()} returns TRUE if the file was deleted and -#' FALSE if not. -#' \item \code{cleanStagingData()} returns a list of files (to be) removed. +#' \item \code{deleteStagingData()} returns TRUE if the data set was deleted +#' and FALSE if not. +#' \item \code{cleanStagingData()} returns a list of data sets (to be) +#' removed. #' \item \code{rapbase:::pathStagingData()} is an internal helper function and #' returns a character string with the path to the staging directory of #' \code{registryName}. If its parent directory (\code{dir}) does not exists @@ -332,8 +335,13 @@ dbStagingData <- function(key, drop = FALSE) { #' @rdname stagingData dbStagingPrereq <- function(key) { + conf <- getConfig()[[key]] + if (is.null(conf)) { + stop(paste("There is no configuration corresponding to key", key)) + } + con <- dbStagingConnection(key, init = TRUE) - query <- "SHOW DATABASES LIKE 'staging';" + query <- paste0("SHOW DATABASES LIKE '", conf$name, "';") df <- RMariaDB::dbGetQuery(con, query) # close and remove db connection con <- dbStagingConnection(con = con) diff --git a/man/stagingData.Rd b/man/stagingData.Rd index 98a309d2..7e6d0719 100644 --- a/man/stagingData.Rd +++ b/man/stagingData.Rd @@ -50,15 +50,16 @@ dbStagingProcess(key, query, params = list(), statement = FALSE) \item{registryName}{Character string providing the registry name.} \item{dir}{Character string providing the path to where the staging data -directory resides. Default value is \code{Sys.getenv("R_RAP_CONFIG_PATH")}.} +directory resides in case of storage as files. Default value is +\code{Sys.getenv("R_RAP_CONFIG_PATH")}.} \item{dataName}{Character string providing the data set name.} \item{data}{A data object such as a data.frame to be stored as \code{dataName}.} -\item{eolAge}{Numeric providing the staging file end-of-life age in seconds. -Based on the current time and the file modification time stamp staging files +\item{eolAge}{Numeric providing the staging data end-of-life age in seconds. +Based on the current time and the time of storage staging files older than \code{eolAge} will be identified as subject for removal.} \item{dryRun}{Logical defining if function is to be run in dry (none @@ -67,18 +68,20 @@ destructive) mode.} \value{ \itemize{ \item \code{listStagingData()} returns a character vector of staging data - files for the given registry (\code{registryName}). - \item \code{mtimeStagingData()} returns a staging file-named POSIXct vector - of modification times for the given registry (\code{registryName}). + sets for the given registry (\code{registryName}). + \item \code{mtimeStagingData()} returns a staging data set named POSIXct + vector of modification times for the given registry + (\code{registryName}). \item \code{saveStagingData()} when successful returns the data object (\code{data}), invisibly. If saving fails a warning is issued and the function returns FALSE. \item \code{loadStagingData()} returns the data object corresponding to the name given upon saving (\code{dataName}). If the requested data set for loading does not exist the function returns FALSE. - \item \code{deleteStagingData()} returns TRUE if the file was deleted and - FALSE if not. - \item \code{cleanStagingData()} returns a list of files (to be) removed. + \item \code{deleteStagingData()} returns TRUE if the data set was deleted + and FALSE if not. + \item \code{cleanStagingData()} returns a list of data sets (to be) + removed. \item \code{rapbase:::pathStagingData()} is an internal helper function and returns a character string with the path to the staging directory of \code{registryName}. If its parent directory (\code{dir}) does not exists @@ -93,9 +96,9 @@ must therefore be established within each registry that take staging data into use. } \details{ -\code{cleanStagingData()} globally removes all staging data files older than -the end-of-life age provided. This is potentially a vastly destructive -function that should be used with great care. +\code{cleanStagingData()} globally removes all staging data with store date +prior to the end-of-life age provided. This is a vastly destructive function +that should be used with great care. } \examples{ ## Prep test data From a3f15ffefce7c2478b3cc8350d1e5f81765cb519 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 8 Dec 2022 09:18:50 +0100 Subject: [PATCH 45/79] now helper functions --- R/stagingData.R | 56 +++++++++++++++++++++++++++++----- man/stagingData.Rd | 15 --------- man/stagingDataHelper.Rd | 66 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 115 insertions(+), 22 deletions(-) create mode 100644 man/stagingDataHelper.Rd diff --git a/R/stagingData.R b/R/stagingData.R index 0700a90c..813e7102 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -47,8 +47,7 @@ #' #' @name stagingData #' @aliases listStagingData mtimeStagingData saveStagingData loadStagingData -#' deleteStagingData cleanStagingData pathStagingData dbStagingData -#' dbStagingPrereq dbStagingConnection dbStagingProcess +#' deleteStagingData cleanStagingData #' #' @examples #' ## Prep test data @@ -283,7 +282,50 @@ cleanStagingData <- function(eolAge, dryRun = TRUE) { } } -#' @rdname stagingData + +#' Data staging helper (internal) functions +#' +#' A set of helper functions to aid staging of registry data at Rapporteket. +#' +#' +#' @param registryName Character string providing the registry name. +#' @param dir Character string providing the path to where the staging data +#' directory resides in case of storage as files. Default value is +#' \code{Sys.getenv("R_RAP_CONFIG_PATH")}. +#' @param key Character string with key to be used for staging data store +#' credentials. +#' @param drop Logical defining if a database is to be deleted. FALSE by +#' default. +#' @param con A database connection object. +#' @param init Logical defining if the function call will perform an initial +#' set-up of a database. Default value is FALSE +#' @param query Character string providing a database query. +#' @param params List of values to be provided in a parameterized query. +#' @param statement Logical defining if a query is a statement or not. Default +#' value is FALSE. +#' +#' @return \itemize{ +#' \item \code{pathStagingData()} returns a character string with the path to +#' the staging directory of \code{registryName}. If its parent directory +#' (\code{dir}) does not exists an error is returned. +#' \item \code{dbStagingData()} creates or drops a staging data database and +#' returns a message invisibly. +#' \item \code{dbStagingPrereq()} ensures that a database for staging data is +#' properly setup and returns a message, invisibly. +#' \item \code{dbStagingConnection()} returns an open database connection +#' object or, when an open connection object is provided as an argument, +#' closes it and returns \code{NULL} invisibly. +#' \item \code{dbStagingProcess()} returns the raw result of a database query +#' based on the arguments provided. +#' } +#' +#' @name stagingDataHelper +#' @keywords internal +#' @aliases pathStagingData dbStagingData dbStagingPrereq dbStagingConnection +#' dbStagingProcess +NULL + +#' @rdname stagingDataHelper pathStagingData <- function(registryName, dir) { stopifnot(dir.exists(dir)) @@ -298,7 +340,7 @@ pathStagingData <- function(registryName, dir) { path } -#' @rdname stagingData +#' @rdname stagingDataHelper dbStagingData <- function(key, drop = FALSE) { conf <- getConfig()[[key]] @@ -332,7 +374,7 @@ dbStagingData <- function(key, drop = FALSE) { invisible(msg) } -#' @rdname stagingData +#' @rdname stagingDataHelper dbStagingPrereq <- function(key) { conf <- getConfig()[[key]] @@ -355,7 +397,7 @@ dbStagingPrereq <- function(key) { invisible(msg) } -#' @rdname stagingData +#' @rdname stagingDataHelper dbStagingConnection <- function(key = NULL, con = NULL, init = FALSE) { if (inherits(con, "DBIConnection")) { @@ -394,7 +436,7 @@ dbStagingConnection <- function(key = NULL, con = NULL, init = FALSE) { } } -#' @rdname stagingData +#' @rdname stagingDataHelper dbStagingProcess <- function(key, query, params = list(), statement = FALSE) { con <- dbStagingConnection(key) diff --git a/man/stagingData.Rd b/man/stagingData.Rd index 7e6d0719..aa765fe0 100644 --- a/man/stagingData.Rd +++ b/man/stagingData.Rd @@ -8,11 +8,6 @@ \alias{loadStagingData} \alias{deleteStagingData} \alias{cleanStagingData} -\alias{pathStagingData} -\alias{dbStagingData} -\alias{dbStagingPrereq} -\alias{dbStagingConnection} -\alias{dbStagingProcess} \title{Staging data functions} \usage{ listStagingData(registryName, dir = Sys.getenv("R_RAP_CONFIG_PATH")) @@ -35,16 +30,6 @@ deleteStagingData( ) cleanStagingData(eolAge, dryRun = TRUE) - -pathStagingData(registryName, dir) - -dbStagingData(key, drop = FALSE) - -dbStagingPrereq(key) - -dbStagingConnection(key = NULL, con = NULL, init = FALSE) - -dbStagingProcess(key, query, params = list(), statement = FALSE) } \arguments{ \item{registryName}{Character string providing the registry name.} diff --git a/man/stagingDataHelper.Rd b/man/stagingDataHelper.Rd new file mode 100644 index 00000000..d33239fb --- /dev/null +++ b/man/stagingDataHelper.Rd @@ -0,0 +1,66 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/stagingData.R +\name{stagingDataHelper} +\alias{stagingDataHelper} +\alias{pathStagingData} +\alias{dbStagingData} +\alias{dbStagingPrereq} +\alias{dbStagingConnection} +\alias{dbStagingProcess} +\title{Data staging helper (internal) functions} +\usage{ +pathStagingData(registryName, dir) + +dbStagingData(key, drop = FALSE) + +dbStagingPrereq(key) + +dbStagingConnection(key = NULL, con = NULL, init = FALSE) + +dbStagingProcess(key, query, params = list(), statement = FALSE) +} +\arguments{ +\item{registryName}{Character string providing the registry name.} + +\item{dir}{Character string providing the path to where the staging data +directory resides in case of storage as files. Default value is +\code{Sys.getenv("R_RAP_CONFIG_PATH")}.} + +\item{key}{Character string with key to be used for staging data store +credentials.} + +\item{drop}{Logical defining if a database is to be deleted. FALSE by +default.} + +\item{con}{A database connection object.} + +\item{init}{Logical defining if the function call will perform an initial +set-up of a database. Default value is FALSE} + +\item{query}{Character string providing a database query.} + +\item{params}{List of values to be provided in a parametrized query.} + +\item{statement}{Logical defining if a query is a statement or not. Default +value is FALSE.} +} +\value{ +\itemize{ + \item \code{pathStagingData()} returns a character string with the path to + the staging directory of \code{registryName}. If its parent directory + (\code{dir}) does not exists an error is returned. + \item \code{dbStagingData()} creates or drops a staging data database and + returns a message invisibly. + \item \code{dbStagingPrereq()} ensures that a database for staging data is + properly setup and returns a message, invisibly. + \item \code{dbStagingConnection()} returns an open database connection + object or, when an open connection object is provided as an argument, + closes it and returns \code{NULL} invisibly. + \item \code{dbStagingProcess()} returns the raw result of a database query + based on the arguments provided. +} +} +\description{ +A set of helper functions to aid staging of registry data at Rapporteket. +} +\keyword{internal} From 5ddb3da1f45a1af180d7313e58b8ad96652aec38 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 8 Dec 2022 09:58:36 +0100 Subject: [PATCH 46/79] dummy config for staging database --- inst/dbConfig.yml | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/inst/dbConfig.yml b/inst/dbConfig.yml index 37ece721..627361ca 100644 --- a/inst/dbConfig.yml +++ b/inst/dbConfig.yml @@ -30,6 +30,14 @@ autoreport: pass : root disp : ForAutoReportDevOnly +# for staging data tests with database as target +staging: + host : db + name : staging + user : root + pass : root + disp : ForStagingDataDevOnly + # for testing, in dev container dev: host : db From bebab971854d105730a1e7955e24c11b63b13dd0 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 8 Dec 2022 10:35:47 +0100 Subject: [PATCH 47/79] missing skip when no db --- tests/testthat/test-stagingData.R | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/testthat/test-stagingData.R b/tests/testthat/test-stagingData.R index 9e553276..484ff756 100644 --- a/tests/testthat/test-stagingData.R +++ b/tests/testthat/test-stagingData.R @@ -193,6 +193,7 @@ test_that("data can be retrieved from staging db", { }) test_that("deleting a none-existing dataset from db returns FALSE", { + checkDb() expect_false(deleteStagingData(registryName, "imaginaryDataSet")) }) From 56bfd9bb67159ff2e56bf9807bd30ec3052fd651 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 12 Dec 2022 10:49:00 +0100 Subject: [PATCH 48/79] encrypt data in db --- R/stagingData.R | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 813e7102..bc51e707 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -136,10 +136,10 @@ saveStagingData <- function(registryName, dataName, data, if (conf$target == "db") { dbStagingPrereq(conf$key) - b <- memCompress( - serialize(data, connection = NULL), - type = "bzip2" - ) + bKey <- digest::digest(getConfig()[[conf$key]]$pass, raw = TRUE) + b <- serialize(data, connection = NULL) %>% + sship::sym_enc(key = bKey, iv = NULL) %>% + memCompress(type = "bzip2") # remove any existing registry data with same data name (should never fail) query <- "DELETE FROM data WHERE registry = ? AND name = ?;" @@ -185,8 +185,10 @@ loadStagingData <- function(registryName, dataName, if (length(df$data) == 0) { data <- FALSE } else { + bKey <- digest::digest(getConfig()[[conf$key]]$pass, raw = TRUE) data <- df$data[[1]] %>% memDecompress(type = "bzip2") %>% + sship::sym_dec(key = bKey, iv = NULL) %>% unserialize() } } From 20243f951f9ca9e1f549fbe23d3ea1a7060d193e Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 12 Dec 2022 15:32:08 +0100 Subject: [PATCH 49/79] outsource wrap/unwrap stageing data (binary) --- R/stagingData.R | 29 +++++++++++++++++++++-------- man/stagingDataHelper.Rd | 10 +++++++++- 2 files changed, 30 insertions(+), 9 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index bc51e707..c393de0e 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -137,9 +137,7 @@ saveStagingData <- function(registryName, dataName, data, if (conf$target == "db") { dbStagingPrereq(conf$key) bKey <- digest::digest(getConfig()[[conf$key]]$pass, raw = TRUE) - b <- serialize(data, connection = NULL) %>% - sship::sym_enc(key = bKey, iv = NULL) %>% - memCompress(type = "bzip2") + b <- wrapStagingData(data, conf$key) # remove any existing registry data with same data name (should never fail) query <- "DELETE FROM data WHERE registry = ? AND name = ?;" @@ -185,11 +183,7 @@ loadStagingData <- function(registryName, dataName, if (length(df$data) == 0) { data <- FALSE } else { - bKey <- digest::digest(getConfig()[[conf$key]]$pass, raw = TRUE) - data <- df$data[[1]] %>% - memDecompress(type = "bzip2") %>% - sship::sym_dec(key = bKey, iv = NULL) %>% - unserialize() + data <- unwrapStagingData(df$data[[1]], conf$key) } } @@ -294,6 +288,7 @@ cleanStagingData <- function(eolAge, dryRun = TRUE) { #' @param dir Character string providing the path to where the staging data #' directory resides in case of storage as files. Default value is #' \code{Sys.getenv("R_RAP_CONFIG_PATH")}. +#' @param data A data object that is to be added to or collected from staging. #' @param key Character string with key to be used for staging data store #' credentials. #' @param drop Logical defining if a database is to be deleted. FALSE by @@ -342,6 +337,24 @@ pathStagingData <- function(registryName, dir) { path } +#' @rdname stagingDataHelper +wrapStagingData <- function(data, key) { + + k <- digest::digest(getConfig()[[key]]$pass, raw = TRUE) + serialize(data, connection = NULL) %>% + sship::sym_enc(key = k, iv = NULL) %>% + memCompress(type = "bzip2") +} + +#' @rdname stagingDataHelper +unwrapStagingData <- function(data, key) { + + k <- digest::digest(getConfig()[[key]]$pass, raw = TRUE) + memDecompress(data, type = "bzip2") %>% + sship::sym_dec(key = k, iv = NULL) %>% + unserialize() +} + #' @rdname stagingDataHelper dbStagingData <- function(key, drop = FALSE) { diff --git a/man/stagingDataHelper.Rd b/man/stagingDataHelper.Rd index d33239fb..5b80188d 100644 --- a/man/stagingDataHelper.Rd +++ b/man/stagingDataHelper.Rd @@ -7,10 +7,16 @@ \alias{dbStagingPrereq} \alias{dbStagingConnection} \alias{dbStagingProcess} +\alias{wrapStagingData} +\alias{unwrapStagingData} \title{Data staging helper (internal) functions} \usage{ pathStagingData(registryName, dir) +wrapStagingData(data, key) + +unwrapStagingData(data, key) + dbStagingData(key, drop = FALSE) dbStagingPrereq(key) @@ -26,6 +32,8 @@ dbStagingProcess(key, query, params = list(), statement = FALSE) directory resides in case of storage as files. Default value is \code{Sys.getenv("R_RAP_CONFIG_PATH")}.} +\item{data}{A data object that is to be added to or collected from staging.} + \item{key}{Character string with key to be used for staging data store credentials.} @@ -39,7 +47,7 @@ set-up of a database. Default value is FALSE} \item{query}{Character string providing a database query.} -\item{params}{List of values to be provided in a parametrized query.} +\item{params}{List of values to be provided in a parameterized query.} \item{statement}{Logical defining if a query is a statement or not. Default value is FALSE.} From 5707f2aeb4eb6a4317f5a1f4dd2a3c6966ac5e0a Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 13 Dec 2022 11:23:52 +0100 Subject: [PATCH 50/79] also encrypt files --- R/stagingData.R | 25 ++++++++++++------------- tests/testthat/test-stagingData.R | 27 ++++++++++++++++++++++++++- 2 files changed, 38 insertions(+), 14 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index c393de0e..06ba84bb 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -124,20 +124,16 @@ mtimeStagingData <- function(registryName, saveStagingData <- function(registryName, dataName, data, dir = Sys.getenv("R_RAP_CONFIG_PATH")) { conf <- getConfig("rapbaseConfig.yml")$r$staging + b <- wrapStagingData(data, registryName) %>% + blob::as_blob() if (conf$target == "file") { path <- pathStagingData(registryName, dir) - return( - invisible( - readr::write_rds(data, file.path(path, dataName)) - ) - ) + saveRDS(b, file.path(path, dataName)) } if (conf$target == "db") { dbStagingPrereq(conf$key) - bKey <- digest::digest(getConfig()[[conf$key]]$pass, raw = TRUE) - b <- wrapStagingData(data, conf$key) # remove any existing registry data with same data name (should never fail) query <- "DELETE FROM data WHERE registry = ? AND name = ?;" @@ -146,15 +142,15 @@ saveStagingData <- function(registryName, dataName, data, # insert new data (can fail, but hard to test...) query <- "INSERT INTO data (registry, name, data) VALUES (?, ?, ?);" - params <- list(registryName, dataName, blob::as_blob(b)) + params <- list(registryName, dataName, b) d <- dbStagingProcess(conf$key, query, params, statement = TRUE) - if (d > 0) { - return(invisible(data)) - } else { + if (d < 1) { warning(paste0("The data set '", dataName, "' could not be saved!")) - return(FALSE) + data <- FALSE } } + + data } #' @rdname stagingData @@ -169,7 +165,9 @@ loadStagingData <- function(registryName, dataName, filePath <- file.path(path, dataName) if (file.exists(filePath)) { - data <- readr::read_rds(filePath) + b <- readRDS(filePath) + # raw is first element in blob list + data <- unwrapStagingData(b[[1]], registryName) } else { data <- FALSE } @@ -183,6 +181,7 @@ loadStagingData <- function(registryName, dataName, if (length(df$data) == 0) { data <- FALSE } else { + # raw is first element in blob list data <- unwrapStagingData(df$data[[1]], conf$key) } } diff --git a/tests/testthat/test-stagingData.R b/tests/testthat/test-stagingData.R index 484ff756..527bb6c0 100644 --- a/tests/testthat/test-stagingData.R +++ b/tests/testthat/test-stagingData.R @@ -24,6 +24,25 @@ cf <- file(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "rapbaseConfig.yml")) writeLines(test_config, cf) close(cf) +# make proper dbConfig +test_config <- paste0( + registryName, ":", + "\n host : ", Sys.getenv("DB_HOST"), + "\n name : test_staging", + "\n user : ", Sys.getenv("DB_USER"), + "\n pass : ", Sys.getenv("DB_PASS"), + "\n disp : registryEphemaralUnitTesting\n", + "staging:", + "\n host : ", Sys.getenv("DB_HOST"), + "\n name : test_staging", + "\n user : ", Sys.getenv("DB_USER"), + "\n pass : ", Sys.getenv("DB_PASS"), + "\n disp : dbBackendEphemaralUnitTesting\n" +) +cf <- file(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "dbConfig.yml")) +writeLines(test_config, cf) +close(cf) + test_that("staging cannot commence if parent directory does not exist", { expect_error(pathStagingData(registryName, dir = "imaginaryDir")) expect_error( @@ -126,12 +145,18 @@ close(cf) # make proper dbConfig test_config <- paste0( + registryName, ":", + "\n host : ", Sys.getenv("DB_HOST"), + "\n name : test_staging", + "\n user : ", Sys.getenv("DB_USER"), + "\n pass : ", Sys.getenv("DB_PASS"), + "\n disp : registryEphemaralUnitTesting\n", "staging:", "\n host : ", Sys.getenv("DB_HOST"), "\n name : test_staging", "\n user : ", Sys.getenv("DB_USER"), "\n pass : ", Sys.getenv("DB_PASS"), - "\n disp : ephemaralUnitTesting\n" + "\n disp : dbBackendEphemaralUnitTesting\n" ) cf <- file(file.path(Sys.getenv("R_RAP_CONFIG_PATH"), "dbConfig.yml")) writeLines(test_config, cf) From 0767a92f00e699ef9f04b9600acb1017008ea549 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 13 Dec 2022 13:19:00 +0100 Subject: [PATCH 51/79] doc detailing --- R/stagingData.R | 16 ++++++++++++---- man/stagingData.Rd | 16 ++++++++++++---- 2 files changed, 24 insertions(+), 8 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 06ba84bb..d8e19db9 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -6,6 +6,13 @@ #' must therefore be established within each registry that take staging data #' into use. #' +#' Staging data can be stored as files or as binary large objects in a database +#' and method of choice is defined by the \code{rapbase} configuration. +#' Regardless of storage method a per registry symmetric encryption of storage +#' content is enforced. Keys used for encryption are generated from existing +#' database credentials. Therefore, please note that removing or changing +#' such credentials will render any historic staging data inaccessible. +#' #' \code{cleanStagingData()} globally removes all staging data with store date #' prior to the end-of-life age provided. This is a vastly destructive function #' that should be used with great care. @@ -51,7 +58,7 @@ #' #' @examples #' ## Prep test data -#' registryName <- "myReg" +#' registryName <- "rapbase" #' dataName <- "testData" #' data <- mtcars #' dir <- tempdir() @@ -59,11 +66,12 @@ #' ## Save data for staging #' saveStagingData(registryName, dataName, data, dir) #' -#' ## List files currently in staging +#' ## List data currently in staging #' listStagingData(registryName, dir) #' -#' ## Retrieve data set from staging -#' loadStagingData(registryName, dataName, dir) +#' ## Retrieve data set from staging and compare to outset +#' stagedData <- loadStagingData(registryName, dataName, dir) +#' identical(data, stagedData) #' #' ## Get modification time for staging file(s) #' mtimeStagingData(registryName, dir) diff --git a/man/stagingData.Rd b/man/stagingData.Rd index aa765fe0..53888d68 100644 --- a/man/stagingData.Rd +++ b/man/stagingData.Rd @@ -81,13 +81,20 @@ must therefore be established within each registry that take staging data into use. } \details{ +Staging data can be stored as files or as binary large objects in a database +and method of choice is defined by the \code{rapbase} configuration. +Regardless of storage method a per registry symmetric encryption of storage +content is enforced. Keys used for encryption are generated from existing +database credentials. Therefore, please note that removing or changing +such credentials will render any historic staging data inaccessible. + \code{cleanStagingData()} globally removes all staging data with store date prior to the end-of-life age provided. This is a vastly destructive function that should be used with great care. } \examples{ ## Prep test data -registryName <- "myReg" +registryName <- "rapbase" dataName <- "testData" data <- mtcars dir <- tempdir() @@ -95,11 +102,12 @@ dir <- tempdir() ## Save data for staging saveStagingData(registryName, dataName, data, dir) -## List files currently in staging +## List data currently in staging listStagingData(registryName, dir) -## Retrieve data set from staging -loadStagingData(registryName, dataName, dir) +## Retrieve data set from staging and compare to outset +stagedData <- loadStagingData(registryName, dataName, dir) +identical(data, stagedData) ## Get modification time for staging file(s) mtimeStagingData(registryName, dir) From 7c67c1b069878c06a41a4f940d250a4e52b0d6a7 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 13 Dec 2022 14:50:16 +0100 Subject: [PATCH 52/79] no less --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 1b16945b..45cebe67 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -43,7 +43,7 @@ Imports: sendmailR, shiny, shinyalert, - sship (>= 0.8.0), + sship (>= 0.9.0), utils, yaml RoxygenNote: 7.2.1 From 2aa049c34cd3178e969934a17cd39b3bdf38346a Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Wed, 14 Dec 2022 10:08:07 +0100 Subject: [PATCH 53/79] no clogging, by default --- R/stagingData.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/stagingData.R b/R/stagingData.R index d8e19db9..207f9b6c 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -158,7 +158,7 @@ saveStagingData <- function(registryName, dataName, data, } } - data + invisible(data) } #' @rdname stagingData From e0fc5e16b7184b4f538a4a898e6756225e70c594 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Wed, 14 Dec 2022 14:02:20 +0100 Subject: [PATCH 54/79] just remove name. kiss! --- inst/howWeDealWithPersonalData.Rmd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/inst/howWeDealWithPersonalData.Rmd b/inst/howWeDealWithPersonalData.Rmd index f2d12754..74bb98d4 100644 --- a/inst/howWeDealWithPersonalData.Rmd +++ b/inst/howWeDealWithPersonalData.Rmd @@ -15,7 +15,7 @@ knitr::opts_chunk$set(echo = TRUE) --- -Hei, `r rapbase::getUserFullName(params$session)`! Her er en kort oppsummering av hva [Rapporteket](https://rapporteket.github.io/rapporteket/articles/kort_introduksjon.html) vet om deg og hvordan denne informasjonen brukes og lagres. +Hei! Her er en kort oppsummering av hva [Rapporteket](https://rapporteket.github.io/rapporteket/articles/kort_introduksjon.html) vet om deg og hvordan denne informasjonen brukes og lagres. * Før bruk av [Rapporteket](https://rapporteket.github.io/rapporteket/articles/kort_introduksjon.html) må du gjennom en identitets- og adgangskontroll hos [helseregister.no](https://helseregister.no/), [FALK](https://www.kvalitetsregistre.no/artikkel/ny-losning-palogging-testes-ut-i-februar) eller lignende. Etter innlogging mottar Rapporteket et sett av informasjon om deg slik som _navn_, _epostadresse_ og _telefonnummer_ samt informasjon om din tilknytning til et gitt register, eksempelvis din rolle/funksjon samt tilhørighet til grupper og organisasjoner. Slik informasjon er nødvendig for at Rapporteket skal kunne fungere som en god og sikker resultattjeneste. From 0c96a2529221abe2ac438090a8548e479d2073cc Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Wed, 14 Dec 2022 14:38:30 +0100 Subject: [PATCH 55/79] less lintr complaints --- R/stagingData.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 207f9b6c..ceb74976 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -279,7 +279,7 @@ cleanStagingData <- function(eolAge, dryRun = TRUE) { } if (conf$target == "db") { query <- "DELETE FROM data WHERE mtime < ?;" - d <- dbStagingProcess(conf$key, query, params, statement = TRUE) + dbStagingProcess(conf$key, query, params, statement = TRUE) } invisible(deleteDataset) } @@ -388,7 +388,7 @@ dbStagingData <- function(key, drop = FALSE) { con <- dbStagingConnection(key = key, init = TRUE) for (q in query) { - tmp <- RMariaDB::dbExecute(con, q) + invisible(RMariaDB::dbExecute(con, q)) } con <- dbStagingConnection(con = con) @@ -434,7 +434,7 @@ dbStagingConnection <- function(key = NULL, con = NULL, init = FALSE) { stop( paste0( "Could not connect to database because there is no configuration ", - "corresponding to key '", key,"'. Please check key and/or ", + "corresponding to key '", key, "'. Please check key and/or ", "configuration." ) ) @@ -472,5 +472,5 @@ dbStagingProcess <- function(key, query, params = list(), statement = FALSE) { } con <- dbStagingConnection(con = con) - df -} \ No newline at end of file + invisible(df) +} From 1ebf783bda419b40d15d1cc20f087f275ef37188 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 15 Dec 2022 11:09:14 +0100 Subject: [PATCH 56/79] debug enc --- R/stagingData.R | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index ceb74976..7185cc5d 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -347,7 +347,14 @@ pathStagingData <- function(registryName, dir) { #' @rdname stagingDataHelper wrapStagingData <- function(data, key) { - k <- digest::digest(getConfig()[[key]]$pass, raw = TRUE) + k <- digest::digest(getConfig()[[key]]$pass, serialize = FALSE, raw = TRUE) + ### Remove after debugging + cat( + paste0( + "I will use this key to encrypt: '", paste0(k, collapse = " "), "'" + ) + ) + ### End remove after debugging serialize(data, connection = NULL) %>% sship::sym_enc(key = k, iv = NULL) %>% memCompress(type = "bzip2") @@ -356,7 +363,14 @@ wrapStagingData <- function(data, key) { #' @rdname stagingDataHelper unwrapStagingData <- function(data, key) { - k <- digest::digest(getConfig()[[key]]$pass, raw = TRUE) + k <- digest::digest(getConfig()[[key]]$pass, serialize = FALSE, raw = TRUE) + ### Remove after debugging + cat( + paste0( + "I will use this key to decrypt: '", paste0(k, collapse = " "), "'" + ) + ) + ### End remove after debugging memDecompress(data, type = "bzip2") %>% sship::sym_dec(key = k, iv = NULL) %>% unserialize() From 30e784454bf3f326715bbc678aedc590ed1cc451 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 15 Dec 2022 13:41:40 +0100 Subject: [PATCH 57/79] change hash --- R/stagingData.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 7185cc5d..6e5c5d50 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -347,7 +347,7 @@ pathStagingData <- function(registryName, dir) { #' @rdname stagingDataHelper wrapStagingData <- function(data, key) { - k <- digest::digest(getConfig()[[key]]$pass, serialize = FALSE, raw = TRUE) + k <- digest::digest(getConfig()[[key]]$pass, algo = "sha256", raw = TRUE) ### Remove after debugging cat( paste0( @@ -363,7 +363,7 @@ wrapStagingData <- function(data, key) { #' @rdname stagingDataHelper unwrapStagingData <- function(data, key) { - k <- digest::digest(getConfig()[[key]]$pass, serialize = FALSE, raw = TRUE) + k <- digest::digest(getConfig()[[key]]$pass, algo = "sha256", raw = TRUE) ### Remove after debugging cat( paste0( From d6cd1c7d4283e812887014adeea78fb234f0b4dc Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 15 Dec 2022 15:26:16 +0100 Subject: [PATCH 58/79] wrong lookup! --- R/stagingData.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/stagingData.R b/R/stagingData.R index 6e5c5d50..58133b38 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -190,7 +190,7 @@ loadStagingData <- function(registryName, dataName, data <- FALSE } else { # raw is first element in blob list - data <- unwrapStagingData(df$data[[1]], conf$key) + data <- unwrapStagingData(df$data[[1]], registryName) } } From 85a41d577788596d8cbb6923a2ac155b210b2392 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 16 Dec 2022 11:12:07 +0100 Subject: [PATCH 59/79] clean-up after debu --- R/stagingData.R | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/R/stagingData.R b/R/stagingData.R index 58133b38..2e03a768 100644 --- a/R/stagingData.R +++ b/R/stagingData.R @@ -348,13 +348,6 @@ pathStagingData <- function(registryName, dir) { wrapStagingData <- function(data, key) { k <- digest::digest(getConfig()[[key]]$pass, algo = "sha256", raw = TRUE) - ### Remove after debugging - cat( - paste0( - "I will use this key to encrypt: '", paste0(k, collapse = " "), "'" - ) - ) - ### End remove after debugging serialize(data, connection = NULL) %>% sship::sym_enc(key = k, iv = NULL) %>% memCompress(type = "bzip2") @@ -364,13 +357,6 @@ wrapStagingData <- function(data, key) { unwrapStagingData <- function(data, key) { k <- digest::digest(getConfig()[[key]]$pass, algo = "sha256", raw = TRUE) - ### Remove after debugging - cat( - paste0( - "I will use this key to decrypt: '", paste0(k, collapse = " "), "'" - ) - ) - ### End remove after debugging memDecompress(data, type = "bzip2") %>% sship::sym_dec(key = k, iv = NULL) %>% unserialize() From 41f2aecbb487be1d0c4d12f505f422ed57b5fb02 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 26 Jan 2023 10:57:29 +0100 Subject: [PATCH 60/79] removes irrelevant mysql client error --- R/moduleExport.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/moduleExport.R b/R/moduleExport.R index ef2a8afa..31af0314 100644 --- a/R/moduleExport.R +++ b/R/moduleExport.R @@ -237,7 +237,8 @@ exportDb <- function(registryName, compress = FALSE, session) { conf <- rapbase::getConfig()[[registryName]] cmd <- paste0( "mysqldump ", - "--no-tablespaces --single-transaction --add-drop-database " + "--no-tablespaces --single-transaction --add-drop-database ", + "--column-statistics=0 " ) cmd <- paste0( cmd, "-B -u ", conf$user, " -p", conf$pass, " -h ", conf$host, From 1c57398a1b75ee8139460d641bc094900a35dc5c Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Thu, 26 Jan 2023 15:22:24 +0100 Subject: [PATCH 61/79] doc 2nd gen for contianer apps --- DESCRIPTION | 2 +- R/moduleNavbarWidget.R | 16 +++++++++++----- man/navbarWidget.Rd | 15 ++++++++++----- 3 files changed, 22 insertions(+), 11 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 45cebe67..2791af7d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -46,7 +46,7 @@ Imports: sship (>= 0.9.0), utils, yaml -RoxygenNote: 7.2.1 +RoxygenNote: 7.2.3 URL: https://github.com/Rapporteket/rapbase BugReports: https://github.com/Rapporteket/rapbase/issues Suggests: diff --git a/R/moduleNavbarWidget.R b/R/moduleNavbarWidget.R index abc7cc8d..a3426526 100644 --- a/R/moduleNavbarWidget.R +++ b/R/moduleNavbarWidget.R @@ -6,7 +6,12 @@ #' #' These modules take use of the shiny session object to obtain data for the #' widget. Hence, a Rapporteket like context will be needed for these modules to -#' function properly. +#' function properly. For deployment of (shiny) application as containers make +#' sure to migrate to \code{navbarWidgetServer2()}. In addition to serving the +#' user information widget, this function provides a list of reactive user +#' attributes. Hence, when using \code{navbarWidgetServer2()} the source of +#' (static) user attributes is no longer the shiny session object but rather the +#' list object (of reactive user attributes) returned by this function. #' #' @param id Character string providing module namespace #' @param addUserInfo Logical defining if an "about" hyperlink is to be added @@ -22,11 +27,12 @@ #' called from outside the registry environment \code{caller} must be set to #' the actual name of the R package. #' -#' @return Shiny objects, mostly. \code{navbarWidgetServer()} invisibly returns -#' a list of reactive values representing user metadata and privileges. See -#' \code{\link{userAttribute}} for further details on these values. +#' @return Shiny objects, mostly. \code{navbarWidgetServer2()} invisibly returns +#' a list of reactive values representing user metadata and privileges. See +#' \code{\link{userAttribute}} for further details on these values. #' @name navbarWidget -#' @aliases navbarWidgetInput navbarWidgetServer2 navbarWidgetApp +#' @aliases navbarWidgetInput navbarWidgetServer navbarWidgetServer2 +#' navbarWidgetApp #' @examples #' ## client user interface function #' ui <- shiny::tagList( diff --git a/man/navbarWidget.Rd b/man/navbarWidget.Rd index 5d5163ec..1611499b 100644 --- a/man/navbarWidget.Rd +++ b/man/navbarWidget.Rd @@ -3,9 +3,9 @@ \name{navbarWidget} \alias{navbarWidget} \alias{navbarWidgetInput} +\alias{navbarWidgetServer} \alias{navbarWidgetServer2} \alias{navbarWidgetApp} -\alias{navbarWidgetServer} \title{Shiny modules providing GUI and server logic for user info widget} \usage{ navbarWidgetInput(id, addUserInfo = TRUE, selectOrganization = FALSE) @@ -40,9 +40,9 @@ called from outside the registry environment \code{caller} must be set to the actual name of the R package.} } \value{ -Shiny objects, mostly. \code{navbarWidgetServer()} invisibly returns -a list of reactive values representing user metadata and privileges. See -\code{\link{userAttribute}} for further details on these values. +Shiny objects, mostly. \code{navbarWidgetServer2()} invisibly returns + a list of reactive values representing user metadata and privileges. See + \code{\link{userAttribute}} for further details on these values. } \description{ Shiny modules for making a user information widget in registry shiny apps at @@ -52,7 +52,12 @@ number of code lines for each registry. \details{ These modules take use of the shiny session object to obtain data for the widget. Hence, a Rapporteket like context will be needed for these modules to -function properly. +function properly. For deployment of (shiny) application as containers make +sure to migrate to \code{navbarWidgetServer2()}. In addition to serving the +user information widget, this function provides a list of reactive user +attributes. Hence, when using \code{navbarWidgetServer2()} the source of +(static) user attributes is no longer the shiny session object but rather the +list object (of reactive user attributes) returned by this function. } \examples{ ## client user interface function From ff236736a7b1b28686fe245b8dde00edf074f703 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 27 Jan 2023 09:24:38 +0100 Subject: [PATCH 62/79] summing up whats new --- NEWS.md | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/NEWS.md b/NEWS.md index adcc922c..7251c4be 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,11 @@ +# rapbase 1.24.0 + +In summary, registries at Rapporteket may now run as standalone container apps. Thus, shiny-server is no longer a requirement for app deployment. Below is a summary of what has been done. + +* Extended handling of user attributes when behind an app proxy (spring boot/shinyproxy) +* Added a database backend for staging data +* Per app (registry) encryption of staging data (regardless of file or database backend) + # rapbase 1.23.1 * Fixed Fixed bug in log sanitizer function ([#130](https://github.com/Rapporteket/rapbase/pull/130)) From 122cdd5c41ebee5e2bb41f4d6dbfbab5aa6763eb Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 27 Jan 2023 14:31:05 +0100 Subject: [PATCH 63/79] staging principles --- .Rbuildignore | 2 ++ .gitignore | 4 ++- DESCRIPTION | 1 + vignettes/.gitignore | 2 ++ vignettes/stagingData.Rmd | 74 +++++++++++++++++++++++++++++++++++++++ 5 files changed, 82 insertions(+), 1 deletion(-) create mode 100644 vignettes/.gitignore create mode 100644 vignettes/stagingData.Rmd diff --git a/.Rbuildignore b/.Rbuildignore index 2c46fa8a..1a90d3d7 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -12,3 +12,5 @@ ^appveyor\.yml$ ^\.lintr$ ^data-raw$ +^doc$ +^Meta$ diff --git a/.gitignore b/.gitignore index d1e57080..a9778d08 100644 --- a/.gitignore +++ b/.gitignore @@ -4,4 +4,6 @@ inst/doc inst/jrxml/*.jasper vignettes/*.pdf -docs/ \ No newline at end of file +docs/ +/doc/ +/Meta/ diff --git a/DESCRIPTION b/DESCRIPTION index 2791af7d..a642c29b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -55,3 +55,4 @@ Suggests: rvest, testthat, withr +VignetteBuilder: knitr diff --git a/vignettes/.gitignore b/vignettes/.gitignore new file mode 100644 index 00000000..097b2416 --- /dev/null +++ b/vignettes/.gitignore @@ -0,0 +1,2 @@ +*.html +*.R diff --git a/vignettes/stagingData.Rmd b/vignettes/stagingData.Rmd new file mode 100644 index 00000000..655dd453 --- /dev/null +++ b/vignettes/stagingData.Rmd @@ -0,0 +1,74 @@ +--- +title: "Staging data: principles and set-up" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Staging data: principles and set-up} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +``` + +## Introduction +Registry applications at Rapporteket normally obtains data by opening connections to a database containing raw registry data. Before figures, tables and reports can be made, data usually have to be filtered, combined and analyzed. Depending on the amount of data and the complexity of the analysis this process can be time-consuming. Quite often, such pre-processing can be generalized and does not have to be run each and every time a user interacts with a registry application. Staging data allow for such pre-processed data to be stored for quick and easy retrieval and therefore reduce the time the registry applications need to spend on processing data. + +This document aim to describe how staging of data works and how to enable it at Rapporteket. + +## Backend +Staging data may be stored as binary files or as blobs in a database. In any case, creating and retrieving staging data follow the same scheme regardless of how it is stored. Selecting a backend is configurable and will apply globally, _i.e._ for all registry applications at Rapporteket. + +### File +To store staging data as binary files make sure to set the property __target__ to the value __file__ in _$R_RAP_CONFIG_PATH/rapbaseConfig.yml_: + +```yaml +... + # Staging data + staging: + target: file + key: staging +... +``` + +When staging data is stored as files the property __key__ is not in use and may take any value. For a given registry _MyRegistry_ staging of the data set _MyData_ will then be stored with the file path _R_RAP_CONFIG_PATH/stagingData/MyRegistry/MyData_. + +### Database +To store staging data as blobs in a database make sure to set the property __target__ to the value __db__ in _$R_RAP_CONFIG_PATH/rapbaseConfig.yml_: + +```yaml +... + # Staging data + staging: + target: db + key: stagingDb +... +``` + +When staging data is stored in a database __key__ must match the corresponding entry in _$R_RAP_CONFIG_PATH/dbConfig.yml_ that provides the database connection credentials: + +```yaml +... +stagingDb: + host: database_server_hostname_or_ip + name: database_name + user: some_username + pass: password_for_some_username + disp: optional_information +... +``` + +The database server must exist and accept connections as defined in the above configuration. If the database itself does not exist when an registry application request staging of data, it will be created. + +## Encryption +Prior to storage the R data structure to become staging data is serialized to binary, encrypted and compressed. When reading data already staged this process is reversed. Encryption is based on the AES256 algorithm and the key applied is generated from the password of the database credentials as defined in _\$R_RAP_CONFIG_PATH/dbConfig.yml_ for the corresponding registry. Hence, there will be a registry specific encryption for staged data meaning that from a common place of storage, staged data will not be accessible across registries. Protection as provided by the encryption solely rest on the accessibility of _\$R_RAP_CONFIG_PATH/dbConfig.yml_ that holds the information needed to decrypt staging data. + + +## Caveats +If the key used for encryption is lost staging data will no longer be accessible. If the key cannot be restored all staging data encrypted with this key will also be forever lost. Hence, if the purpose is to remove staging data, destroying the key will be a very potent method to ensure proper deletion, but please note that making staged data inaccessible may lead to errors in registry applications that uses staged data. For any number of reasons database credentials for registries at Rapporteket may also at some point be altered having the unintentional effect of making staged data inaccessible. + +## Implementation +For developers of registry applications at Rapporteket that wants to implement staging data, please refer to the staging data function documentation: `help("rapbase::stagingData")`. From 84238812bb30e8633d2552960a70ba138df27685 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 30 Jan 2023 14:02:15 +0100 Subject: [PATCH 64/79] checkout from master --- docker-compose.yml | 39 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) create mode 100644 docker-compose.yml diff --git a/docker-compose.yml b/docker-compose.yml new file mode 100644 index 00000000..fcb3d50e --- /dev/null +++ b/docker-compose.yml @@ -0,0 +1,39 @@ +version: '3.3' + +services: + db: + image: mysql:5.7 + command: --innodb-log-file-size=500M --innodb_strict_mode=0 + restart: "no" + environment: + MYSQL_ROOT_PASSWORD: root + + dev: + depends_on: + - db + image: rapporteket/dev:nightly + volumes: + - .:/home/rstudio/rapbase/ + - ~/.ssh:/home/rstudio/.ssh + - ~/.gitconfig:/home/rstudio/.gitconfig + ports: + - "8787:8787" + - "3838:3838" + dns: + - 8.8.8.8 + restart: "no" + environment: + PASSWORD: password + DB_HOST: db + DB_USER: root + DB_PASS: root + + adminer: + depends_on: + - db + image: adminer + restart: "no" + environment: + ADMINER_PLUGINS: frames + ports: + - 8888:8080 From 055f2254020e0a2610470997dd549bc558a51567 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 30 Jan 2023 14:02:51 +0100 Subject: [PATCH 65/79] this sub-pr --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index a642c29b..51503e32 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rapbase Type: Package Title: Base Functions and Resources for Rapporteket -Version: 1.23.1.9000 +Version: 1.23.1.9001 Authors@R: c( person(given = "Are", family = "Edvardsen", From 6bf3b1aa7b80299b751c0cb70fe2689467db1de1 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 30 Jan 2023 14:07:15 +0100 Subject: [PATCH 66/79] ignor our dev env spec --- .Rbuildignore | 1 + 1 file changed, 1 insertion(+) diff --git a/.Rbuildignore b/.Rbuildignore index 1a90d3d7..b91aead1 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -14,3 +14,4 @@ ^data-raw$ ^doc$ ^Meta$ +^docker-compose.yml$ From 64ea16045c078cc64b349cf6e2eb58c0cae7b2fa Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 30 Jan 2023 14:10:03 +0100 Subject: [PATCH 67/79] more news --- NEWS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/NEWS.md b/NEWS.md index 7251c4be..d41a845a 100644 --- a/NEWS.md +++ b/NEWS.md @@ -5,6 +5,7 @@ In summary, registries at Rapporteket may now run as standalone container apps. * Extended handling of user attributes when behind an app proxy (spring boot/shinyproxy) * Added a database backend for staging data * Per app (registry) encryption of staging data (regardless of file or database backend) +* Added a vignette with a short description of staging data server side set-up # rapbase 1.23.1 From cf04e26258cea97daeb6b89a5a94baa36c678a52 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Wed, 1 Feb 2023 09:06:53 +0100 Subject: [PATCH 68/79] remove PoC specifics --- R/userAttribute.R | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/R/userAttribute.R b/R/userAttribute.R index 12cd91e6..702bbd15 100644 --- a/R/userAttribute.R +++ b/R/userAttribute.R @@ -234,16 +234,6 @@ userAttribute <- function(group, unit = NULL) { )) } - ### DUE TO CURRENT LIMITATIONS TO FALK (currently application type OQR) ### - # HARD CODED ROLES HAVE TO BE MAPPED TO SHINYPROXY APPLICATION PRIVILEGES # - # THEREFORE, THE NEXT SECTION IS TO BE REMOVED ONCE A PROPER RAPPORTEKET # - # APPLICATION TYPE IS IN PLACE. # - ### ------------------- REMOVE THE SECTION BELOW! ------------------------- # - groups[groups == "LU"] <- "falkdemo" - groups[groups == "LC"] <- "ablanor" - groups[groups == "SC"] <- "rapadm" - - # NB Anticipate that element positions in vectors do correspond! ## filter by this group units <- units[groups == group] From 65436e4b4489ba5fdd92f4d284a8d8f52db5ab00 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 20 Feb 2023 10:34:09 +0100 Subject: [PATCH 69/79] describe breaking change --- NEWS.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/NEWS.md b/NEWS.md index d41a845a..f6f4af1e 100644 --- a/NEWS.md +++ b/NEWS.md @@ -7,6 +7,9 @@ In summary, registries at Rapporteket may now run as standalone container apps. * Per app (registry) encryption of staging data (regardless of file or database backend) * Added a vignette with a short description of staging data server side set-up +## Breaking changes +By introducing encryption, staging data will not work across this and previous versions. All existing staging data should therefore be removed when upgrading to this version of rapbase (or downgrading from this to any previous version). To remove all staging data delete all related files and directories. If staging data uses a database backend, the database itself should be dropped. There should be no need for further actions as both files and database will be recreated upon the next request for storing of staging data. + # rapbase 1.23.1 * Fixed Fixed bug in log sanitizer function ([#130](https://github.com/Rapporteket/rapbase/pull/130)) From 34f18f5b003a4847f55a0df7a8e4addbcc615313 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 21 Feb 2023 10:47:00 +0100 Subject: [PATCH 70/79] clean-up and prep --- .Rbuildignore | 1 + DESCRIPTION | 3 +-- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.Rbuildignore b/.Rbuildignore index 490fb540..c8338d63 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -14,3 +14,4 @@ ^doc$ ^Meta$ ^docker-compose.yml$ +^.devcontainer$ diff --git a/DESCRIPTION b/DESCRIPTION index 51503e32..cdb1055e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: rapbase Type: Package Title: Base Functions and Resources for Rapporteket -Version: 1.23.1.9001 +Version: 1.24.0 Authors@R: c( person(given = "Are", family = "Edvardsen", @@ -24,7 +24,6 @@ LazyData: true Depends: R (>= 3.5.0) Imports: - base64enc, blob, bookdown, DBI, From dc22bd932a4767c3ed410f5c8fcb6110592031b3 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 21 Feb 2023 11:02:56 +0100 Subject: [PATCH 71/79] spelling --- NEWS.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/NEWS.md b/NEWS.md index f6f4af1e..1f4a4c19 100644 --- a/NEWS.md +++ b/NEWS.md @@ -40,7 +40,7 @@ By introducing encryption, staging data will not work across this and previous v * Fix short-term error in function finding next run date in auto reports * As result of the above a new field "startDate" was added to auto report data with functions for upgrading existing data missing this field ([#99](https://github.com/Rapporteket/rapbase/pull/99)) and the start date is checked before reports are run ([#100](https://github.com/Rapporteket/rapbase/pull/100)) -* R package sship now installed from Cran rather than GitHUb ([#101](https://github.com/Rapporteket/rapbase/pull/101)) +* R package sship now installed from Cran rather than GitHub ([#101](https://github.com/Rapporteket/rapbase/pull/101)) # rapbase 1.20.1 @@ -56,7 +56,7 @@ By introducing encryption, staging data will not work across this and previous v # rapbase 1.19.3 -* Added T1 fontencoding to default LaTeX template for proper printing of symbols (_e.g._ > and <) in pdfs ([#94](https://github.com/Rapporteket/rapbase/pull/94)) +* Added T1 font encoding to default LaTeX template for proper printing of symbols (_e.g._ > and <) in pdfs ([#94](https://github.com/Rapporteket/rapbase/pull/94)) * Replaced function none ascii with unicode characters # rapbase 1.19.2 From 63824c0a07987ebd3689c45990f2764973fbbb47 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 21 Feb 2023 11:18:59 +0100 Subject: [PATCH 72/79] keep only verbatime --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 49a5ab50..7a4e382a 100644 --- a/README.md +++ b/README.md @@ -45,7 +45,7 @@ For kick-starting, a development environment set-up is included and may be appli ```bash docker-compose up ``` -Navigate a browser to [localhost:8787](localhost:8787), log in to the [RStudio IDE](https://posit.co/products/open-source/rstudio/) and initiate the project by "clicking" the file *rapbase.Rproj* inside the *rapbase* directory. For development all suggested imports for the *rapbase* R package will be needed. To make sure these are installed use the R Console and run +Navigate a browser to localhost:8787, log in to the [RStudio IDE](https://posit.co/products/open-source/rstudio/) and initiate the project by "clicking" the file *rapbase.Rproj* inside the *rapbase* directory. For development all suggested imports for the *rapbase* R package will be needed. To make sure these are installed use the R Console and run ```r devtools::install_dev_deps() ``` From e24d88b2af04b4dedc61c7d8422fc1e44ec9ae1f Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 21 Feb 2023 15:10:33 +0100 Subject: [PATCH 73/79] upgrade check environment --- .github/workflows/R-CMD-check.yaml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index 1b1693a6..ae79d345 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -24,9 +24,9 @@ jobs: config: - {os: windows-latest, r: 'release'} - {os: macOS-latest, r: 'release'} - - {os: ubuntu-20.04, r: 'release'} - - {os: ubuntu-20.04, r: 'devel'} - - {os: ubuntu-18.04, r: 'oldrel'} + - {os: ubuntu-22.04, r: 'release'} + - {os: ubuntu-22.04, r: 'devel'} + - {os: ubuntu-20.04, r: 'oldrel'} - {os: ubuntu-20.04, r: '3.6'} env: From accf15ee328c421f66af58949e9bef1146a132ef Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Tue, 21 Feb 2023 15:33:32 +0100 Subject: [PATCH 74/79] stick with the old ubuntu --- .github/workflows/R-CMD-check.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/R-CMD-check.yaml b/.github/workflows/R-CMD-check.yaml index ae79d345..afbd531f 100644 --- a/.github/workflows/R-CMD-check.yaml +++ b/.github/workflows/R-CMD-check.yaml @@ -24,8 +24,8 @@ jobs: config: - {os: windows-latest, r: 'release'} - {os: macOS-latest, r: 'release'} - - {os: ubuntu-22.04, r: 'release'} - - {os: ubuntu-22.04, r: 'devel'} + - {os: ubuntu-20.04, r: 'release'} + - {os: ubuntu-20.04, r: 'devel'} - {os: ubuntu-20.04, r: 'oldrel'} - {os: ubuntu-20.04, r: '3.6'} From 2aa3912d7526d5c5f62ff7fe7f9158418fa0e1bd Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 24 Feb 2023 13:00:00 +0100 Subject: [PATCH 75/79] please, no url check --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 7a4e382a..785671de 100644 --- a/README.md +++ b/README.md @@ -45,7 +45,7 @@ For kick-starting, a development environment set-up is included and may be appli ```bash docker-compose up ``` -Navigate a browser to localhost:8787, log in to the [RStudio IDE](https://posit.co/products/open-source/rstudio/) and initiate the project by "clicking" the file *rapbase.Rproj* inside the *rapbase* directory. For development all suggested imports for the *rapbase* R package will be needed. To make sure these are installed use the R Console and run +Navigate a browser to localhost on port 8787, log in to the [RStudio IDE](https://posit.co/products/open-source/rstudio/) and initiate the project by "clicking" the file *rapbase.Rproj* inside the *rapbase* directory. For development all suggested imports for the *rapbase* R package will be needed. To make sure these are installed use the R Console and run ```r devtools::install_dev_deps() ``` From 4aa4cb910c1bc8c84d53649c579f91b739964989 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 24 Feb 2023 14:33:21 +0100 Subject: [PATCH 76/79] new codecov urls --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 785671de..e1a8da81 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ [![Version](https://img.shields.io/github/v/release/rapporteket/rapbase?sort=semver)](https://github.com/rapporteket/rapbase/releases) [![R build status](https://github.com/Rapporteket/rapbase/workflows/R-CMD-check/badge.svg)](https://github.com/Rapporteket/rapbase/actions) -[![codecov.io](https://codecov.io/github/Rapporteket/rapbase/rapbase.svg?branch=master)](https://codecov.io/github/Rapporteket/rapbase?branch=master) +[![codecov.io](https://codecov.io/gh/Rapporteket/rapbase/branch/master/graph/badge.svg)](https://app.codecov.io/gh/rapporteket/rapbase?branch=master) [![CRAN status](https://www.r-pkg.org/badges/version/rapbase)](https://CRAN.R-project.org/package=rapbase) [![Lifecycle: stable](https://img.shields.io/badge/lifecycle-stable-green.svg)](https://lifecycle.r-lib.org/articles/stages.html) [![Doc](https://img.shields.io/badge/Doc--grey.svg)](https://rapporteket.github.io/rapbase/) From 54d9b52be0883626a0fd277cda294f14d136557f Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Fri, 24 Feb 2023 15:53:08 +0100 Subject: [PATCH 77/79] under construction --- cran-comments.md | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/cran-comments.md b/cran-comments.md index f4f06f38..3e374194 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -2,8 +2,8 @@ ### CRAN win-builder -* x86_64-w64-mingw32 (64-bit): R Under development (unstable) (2022-08-15 r82719 ucrt) -* x86_64-w64-mingw32 (64-bit): R version 4.2.1 (2022-06-23 ucrt) +* x86_64-w64-mingw32 (64-bit): R Under development (unstable) (2023-02-23 r83894 ucrt) +* x86_64-w64-mingw32 (64-bit): R version 4.2.2 (2022-10-31 ucrt) ### R-hub @@ -11,6 +11,9 @@ * Fedora Linux (clang, gfortran) x86_64-pc-linux-gnu: R Under development (unstable) (2022-08-15 r82721) * Debian Linux, GCC (debian-gcc-devel): R Under development (unstable) (2022-07-31 r82648) +* Fedora Linux, +* Debian Linux, debian-gcc-release x86_64-pc-linux-gnu (64-bit): R version 4.2.2 Patched (2022-11-10 r83330) + ### GitHub Actions * Ubuntu 20.04.4 LTS x86_64: R Under development (unstable) (2022-08-11 r82713) From bbad0f28528b1f2affd254b842374b3edcc0573d Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 27 Feb 2023 09:12:19 +0100 Subject: [PATCH 78/79] more and less comments --- cran-comments.md | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/cran-comments.md b/cran-comments.md index 3e374194..9c4e599c 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -7,11 +7,8 @@ ### R-hub -* Apple Silicon (M1), macOS 11.6 Big Sur: R version 4.1.3 (2022-03-10) -* Fedora Linux (clang, gfortran) x86_64-pc-linux-gnu: R Under development (unstable) (2022-08-15 r82721) -* Debian Linux, GCC (debian-gcc-devel): R Under development (unstable) (2022-07-31 r82648) - -* Fedora Linux, +* macOS 10.13.6 High Sierra, (CRANS's setup) x86_64-apple-darwin17.0 (64-bit): R version 4.1.1 (2021-08-10) +* Fedora Linux, (clang, gfortran) x86_64-redhat-linux-gnu: R Under development (unstable) (2023-02-23 r83895) * Debian Linux, debian-gcc-release x86_64-pc-linux-gnu (64-bit): R version 4.2.2 Patched (2022-11-10 r83330) ### GitHub Actions From 9bbc085e65d69c8b2d51e737bed855c811a30c01 Mon Sep 17 00:00:00 2001 From: Are Edvardsen Date: Mon, 27 Feb 2023 10:42:36 +0100 Subject: [PATCH 79/79] failing one of crans own check --- cran-comments.md | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/cran-comments.md b/cran-comments.md index 9c4e599c..3846d46b 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -13,19 +13,16 @@ ### GitHub Actions -* Ubuntu 20.04.4 LTS x86_64: R Under development (unstable) (2022-08-11 r82713) -* Ubuntu 20.04.4 LTS x86_64: R version 4.2.1 (2022-06-23) -* Ubuntu 18.04.6 LTS: R version 4.1.3 (2022-03-10) -* Ubuntu 20.04.4 LTS x86_64: R version 3.6.3 (2020-02-29) -* macOS Big Sur ... 10.16 x86_64: R version 4.2.1 (2022-06-23) -* Windows Server x64, x86_64: R version 4.2.1 (2022-06-23 ucrt) +* Ubuntu 20.04.5 LTS x86_64, linux-gnu: R Under development (unstable) (2023-02-22 r83892) +* Ubuntu 20.04.5 LTS x86_64, linux-gnu: R version 4.2.2 (2022-10-31) +* Ubuntu 20.04.5 LTS x86_64, linux-gnu: R version 4.1.3 (2022-03-10) +* Ubuntu 20.04.5 LTS x86_64, linux-gnu: R version 3.6.3 (2020-02-29) +* macOS Big Sur ... 10.16 x86_64, darwin17.0: R version 4.2.2 (2022-10-31) +* Windows Server x64 (build 20348), x86_64, mingw32: R version 4.2.2 (2022-10-31 ucrt) ## R CMD check results -There were no ERRORs or WARNINGs. +There were no NOTEs, ERRORs or WARNINGs. -There was one NOTE: - -* Version jumps in minor (submitted: 1.23.0, existing: 1.10.0) - -Due to change of internal regulations all future official versions may now be hosted by the CRAN Repository (CRAN) following the CRAN policies and submission processes. +## CRAN Package Check Results for Package rapbase +I am aware of a failed check on the r-oldrel-windows-ix86+x86_64 flavor, but must admit I do not understand why it fails (install log '' does not exist). \ No newline at end of file