#' Generate an encoding key which is used for encoding and decoding strings to pass the R parser
#'
#' @return A list containing the encoding key, with 'input' specifying the characters to be encoded
#' and 'output' specifying their corresponding encoded values.
#' @noRd
.get_encode_dictionary <- function() {
  encode_list <- list(
    input = c("(", ")", "\"", ",", " ", "!", "&", "|", "'", "=", "+", "-", "*", "/", "^", ">", "<", "~", "\n", "%"),
    output = c(
      "$LB$", "$RB$", "$QUOTE$", "$COMMA$", "$SPACE$", "$EXCL$", "$AND$", "$OR$",
      "$APO$", "$EQU$", "$ADD$", "$SUB$", "$MULT$", "$DIVIDE$", "$POWER$", "$GT$", "$LT$", "$TILDE$", "$LINE$", "$PCT$"
    )
  )
  return(encode_list)
}

#' Decode a string using the provided encoding key.
#'
#' @param input_string The encoded string passed through the R parser.
#' @param encode_key The encoding key generated by '.get_encode_dictionary()'.
#' @return The decoded string.
#' @noRd
.decode_tidy_eval <- function(input_string, encode_key) {
  encode_vec <- encode_key$input
  names(encode_vec) <- encode_key$output
  output_string <- Reduce(function(out, pattern) {
    gsub(pattern, encode_vec[[pattern]], out, fixed = TRUE)
  }, names(encode_vec), input_string)
  return(output_string)
}

#' Create a tidyverse call expression
#'
#' This function creates a tidyverse call expression in string form,
#' using the provided data frame, function name, tidy select statement,
#' and additional arguments.
#'
#' @param .data The name of the data frame.
#' @param fun The name of the function to be applied (e.g., "select").
#' @param tidy_select The tidy select statement (e.g., column names).
#' @param other_args Additional arguments to the function.
#' @param inc_data Boolean, whether to include a data object in the call
#' @importFrom rlang parse_expr
#' @return An expression object of the tidyverse call.
#' @noRd
.make_tidyverse_call <- function(.data, fun, tidy_expr, other_args = NULL, inc_data = TRUE) {
  if (!is.null(tidy_expr) & is.null(other_args)) {
    tidy_string <- paste0("dplyr::", fun, "(", tidy_expr, ")")
  } else if (!length(tidy_expr) == 0 & !is.null(other_args)) {
    tidy_string <- paste0("dplyr::", fun, "(", tidy_expr, ", ", other_args, ")")
  } else if (length(tidy_expr) == 0 & !is.null(other_args)) {
    tidy_string <- paste0("dplyr::", fun, "(", other_args, ")")
  } else if (length(tidy_expr) == 0 & is.null(other_args)) {
    tidy_string <- paste0("dplyr::", fun, "(", ")")
  }

  if (inc_data) {
    tidy_string <- paste0(.data, " |> ", tidy_string)
  }
  return(rlang::parse_expr(tidy_string))
}

#' Paste Character Arguments
#'
#' This function takes any number of arguments and returns a formatted string
#' that includes the argument names and their corresponding values.
#'
#' @param ... Any number of arguments.
#' @return A character string with the argument names and values.
#' @noRd
.paste_character_args <- function(...) {
  arg_values <- lapply(list(...), deparse)
  call_stack <- sys.call()
  arg_names <- as.character(call_stack)[-1]
  names(arg_values) <- arg_names
  args_formatted <- mapply(function(name, value) paste0(name, " = ", value),
                           arg_names, arg_values, SIMPLIFY = FALSE)
  args_as_vector <- paste(unlist(args_formatted), collapse = ", ")
  return(args_as_vector)
}


#' Build an evaluation environment with permitted dplyr functions
#'
#' Creates a new environment parented by \code{caller_env} and populates it with
#' permitted dplyr functions so they are available during tidy evaluation.
#'
#' @param caller_env The environment containing the data objects (e.g. the DataSHIELD server environment).
#' @return A new environment with permitted dplyr functions, parented by \code{caller_env}.
#' @importFrom dplyr desc
#' @noRd
.build_eval_env <- function(caller_env) {
  eval_env <- new.env(parent = caller_env)
  permitted <- listPermittedTidyverseFunctionsDS()
  dplyr_ns <- asNamespace("dplyr")
  for (fn in permitted) {
    if (exists(fn, envir = dplyr_ns, inherits = FALSE)) {
      eval_env[[fn]] <- get(fn, envir = dplyr_ns)
    }
  }
  eval_env
}

#' Evaluate an expression and handle errors gracefully.
#'
#' @param fun The name of the calling function, used in error messages.
#' @param string_as_expr An expression to be evaluated.
#' @importFrom cli cli_abort
#' @importFrom rlang eval_tidy
#' @return The result of evaluating the expression, or an error message if evaluation fails.
#' @noRd
.execute_with_error_handling <- function(fun, string_as_expr) {
  caller_env <- parent.frame(2)
  eval_env <- .build_eval_env(caller_env)
  object_out <- tryCatch(
    eval_tidy(string_as_expr, env = eval_env),
    error = function(e) {
      cli_abort(
        c("`{fun}DS` returned the following error:", "i" = conditionMessage(e)),
        call = NULL
      )
    }
  )
  return(object_out)
}

#' @title listDisclosureSettingsDS
#' @description This server-side function is an aggregate function that is called by the
#' ds.listDisclosureSettings
#' @details For more details see the extensive header for ds.listDisclosureSettings
#' @author Paul Burton, Demetris Avraam for DataSHIELD Development Team
#' @noRd
listDisclosureSettingsDS <- function() {
  ds.privacyControlLevel <- getOption("datashield.privacyControlLevel")
  if (is.null(ds.privacyControlLevel)) {
    ds.privacyControlLevel <- getOption("default.datashield.privacyControlLevel")
  }

  nf.tab <- getOption("nfilter.tab")
  if (is.null(nf.tab)) {
    nf.tab <- getOption("default.nfilter.tab")
  }
  nf.subset <- getOption("nfilter.subset")
  if (is.null(nf.subset)) {
    nf.subset <- getOption("default.nfilter.subset")
  }
  nf.glm <- getOption("nfilter.glm")
  if (is.null(nf.glm)) {
    nf.glm <- getOption("default.nfilter.glm")
  }
  nf.string <- getOption("nfilter.string")
  if (is.null(nf.string)) {
    nf.string <- getOption("default.nfilter.string")
  }
  nf.stringShort <- getOption("nfilter.stringShort")
  if (is.null(nf.stringShort)) {
    nf.stringShort <- getOption("default.nfilter.stringShort")
  }
  nf.kNN <- getOption("nfilter.kNN")
  if (is.null(nf.kNN)) {
    nf.kNN <- getOption("default.nfilter.kNN")
  }
  nf.levels.density <- getOption("nfilter.levels.density")
  if (is.null(nf.levels.density)) {
    nf.levels.density <- getOption("default.nfilter.levels.density")
  }
  nf.levels.max <- getOption("nfilter.levels.max")
  if (is.null(nf.levels.max)) {
    nf.levels.max <- getOption("default.nfilter.levels.max")
  }
  nf.noise <- getOption("nfilter.noise")
  if (is.null(nf.noise)) {
    nf.noise <- getOption("default.nfilter.noise")
  }
  nfilter.privacy.old <- getOption("datashield.privacyLevel")

  return(list(
    datashield.privacyControlLevel = ds.privacyControlLevel, nfilter.tab = nf.tab, nfilter.subset = nf.subset,
    nfilter.glm = nf.glm, nfilter.string = nf.string,
    nfilter.stringShort = nf.stringShort, nfilter.kNN = nf.kNN, nfilter.levels.density = nf.levels.density,
    nfilter.levels.max = nf.levels.max, nfilter.noise = nf.noise, nfilter.privacy.old = nfilter.privacy.old
  ))
}

#' List of Permitted Tidyverse Functions
#'
#' This function returns a vector of function names that are permitted to be passed within the
#' dsTidyverse functions, e.g. within the `tidy_select` argument of `ds.mutate.`
#' Additional functions can be added via the \code{tidyverse.permitted.functions} R option.
#' Only functions from base R, dplyr, or tidyselect are supported.
#'
#' @return A character vector of function names, each representing a permitted function. Functions
#' not included in this list will be blocked.
#' @export
listPermittedTidyverseFunctionsDS <- function() {
  defaultFunctions <- c(
    "everything", "last_col", "group_cols", "starts_with", "ends_with", "contains",
    "matches", "num_range", "all_of", "any_of", "where", "rename", "mutate", "if_else",
    "case_when", "mean", "median", "desc",
    "exp", "sqrt", "scale", "round", "floor", "ceiling", "abs", "sd", "var",
    "sin", "cos", "tan", "asin", "acos", "atan", "c", "as.character", "as.integer", "as.numeric",
    "lag", "cumsum", "is.na", "as.Date"
  )

  permittedFunctions <- getOption("tidyverse.permitted.functions", defaultFunctions)

  return(permittedFunctions)
}

#' Check Subset Disclosure Risk
#'
#' This function checks the disclosure risk when applying creating a subset of a dataset.
#' It evaluates the subset size and the difference in rows between the original
#' and subsetted data to ensure they meet the minimum threshold specified by
#' `nfilter.subset`.
#'
#' @param .data A string representing the name of the original dataset.
#' @param out The subset.
#' @keywords internal
#' @return None. The function will throw an error if disclosure risk is detected.
#' @noRd
.check_subset_disclosure_risk <- function(original, out) {
  nfilter.subset <- .get_nfilter_subset_value()
  dims <- .get_dimensions(original, out)
  .check_subset_size(dims$subset, nfilter.subset)
  .check_rows_compared_with_original(dims$original, dims$subset, nfilter.subset)
}

#' Get `nfilter.subset` Value
#'
#' This function retrieves the value of `nfilter.subset` from the disclosure
#' settings.
#'
#' @keywords internal
#' @return The value of `nfilter.subset` from the disclosure settings.
#' @noRd
.get_nfilter_subset_value <- function() {
  return(
    listDisclosureSettingsDS()$nfilter.subset
  )
}

#' Get Dimensions of Original and Subset Data
#'
#' This function calculates the number of rows in the original and subsetted datasets.
#'
#' @param .data A string representing the name of the original dataset.
#' @param out The filtered dataset object.
#' @keywords internal
#' @return A list containing the number of rows in the original and subsetted datasets.
#' @noRd
.get_dimensions <- function(original, out) {
  return(
    list(
      original = dim(original)[[1]],
      subset = dim(out)[[1]]
    )
  )
}

#' Check Subset Size
#'
#' This function checks if the number of rows in the subsetted data is below the
#' threshold defined by `nfilter.subset`. If it is, the function throws an error.
#'
#' @param subset_rows The number of rows in the subsetted data.
#' @param nfilter.subset The minimum allowed size for a subset as defined in the
#' disclosure settings.
#' @keywords internal
#' @return None. The function will throw an error if the subset size is too small.
#' @noRd
.check_subset_size <- function(subset_rows, nfilter.subset) {
  if (subset_rows < nfilter.subset) {
    cli_abort(
      "Subset to be created is too small (< nfilter.subset)",
      call = NULL
    )
  }
}

#' Check Rows Compared with Original
#'
#' This function checks the difference in the number of rows between the original
#' and subsetted data. If the difference is smaller than `nfilter.subset` but
#' greater than zero, it raises an error, indicating a potential disclosure risk.
#'
#' @param original_rows The number of rows in the original dataset.
#' @param subset_rows The number of rows in the subsetted dataset.
#' @param nfilter.subset The minimum allowed difference between the original and
#' subsetted data, as defined in the disclosure settings.
#' @keywords internal
#' @return None. The function will throw an error if a potential disclosure risk
#' is detected.
#' @noRd
.check_rows_compared_with_original <- function(original_rows, subset_rows, nfilter.subset) {
  diff <- original_rows - subset_rows
  if ((diff < nfilter.subset) & (diff > 0)) {
    cli_abort(
      "The difference in row length between the original dataframe and the new dataframe is {diff},
      which is lower than the value of nfilter.subset ({nfilter.subset}). This could indicate a potential subsetting
      attack which will be recorded in the server-side logs. Please review the filter expression.",
      call = NULL
    )
  }
}

#' Get single disclosure setting
#'
#' @param setting the disclosure setting to return
#' @return The value of setting from the disclosure settings.
#' @noRd
.get_disclosure_value <- function(setting) {
  return(
    listDisclosureSettingsDS()[[setting]]
  )
}

#' Check if the functions used in tidy evaluation are permitted.
#'
#' @param args_as_string The string representation of the arguments.
#' @importFrom cli cli_abort
#' @details To avoid users attempting to maliciously pass functions to the servervia the tidy_select
#' argument, a regex is used to first extract all functions from the string by identifying any characters
#' with the format 'name('. These are then checked against permitted arguments, which are selection
#' helpers described in the ?select documentation.#'
#' @noRd
.check_function_names <- function(args_as_string) {
  permitted_tidy_select <- listPermittedTidyverseFunctionsDS()
  matches <- gregexpr("[A-Za-z][A-Za-z0-9_]*(?:\\.[A-Za-z0-9_]+)*(?=\\()", args_as_string, perl = TRUE)
  function_names <- unlist(regmatches(args_as_string, matches))
  any_banned_functions <- function_names[!function_names %in% permitted_tidy_select]
  if (length(any_banned_functions) > 0) {
    message <- c(
      "Values passed to `expr` may only contain permitted functions.",
      "Permitted functions are {permitted_tidy_select}.",
      "`{any_banned_functions}` {?is/are} not {?a/} permitted function{?s}."
    )
    names(message) <- c("", "i", "i")
    cli_abort(message, call = NULL)
  }
}

#' Check if the length of variable names in tidy evaluation exceeds a nfilter.string threshold.
#'
#' @param args_as_string The string representation of the arguments.
#' @param disclosure list of disclosure settings, length of number of cohorts
#' @importFrom cli cli_abort
#' @details To check users are not passing variable names which are too long, first a regex extracts
#' variable names from the list passed to `tidy_select`. It then checks the lengths of these against
#' the value passed to nfilter.string.#'
#' @noRd
.check_variable_length <- function(args_as_string, disclosure) {
  matches <- gregexpr("\\b\\w+\\b(?!\\()", args_as_string, perl = TRUE)
  variable_names <- unlist(regmatches(args_as_string, matches))

  if(length(variable_names) > 0) {
    variable_lengths <- sapply(variable_names, nchar)
    over_filter_thresh <- .check_exceeds_threshold(variable_names, variable_lengths, disclosure$nfilter.string)

  if (length(over_filter_thresh) > 0) {
    disclosure_message <- .format_disclosure_errors(disclosure)
    cli_abort(disclosure_message, call = NULL)
  }
  }
}

#' Check Which Variables Exceed a Threshold
#'
#' This function checks if the lengths of the given variables exceed a specified threshold.
#' It returns the names of the variables whose lengths are greater than the threshold.
#'
#' @param variable_names A character vector containing the names of the variables.
#' @param variable_lengths A numeric vector containing the lengths of the variables, in the same order as `variable_names`.
#' @param threshold A numeric value specifying the threshold that each variable length is compared against.
#' @return A character vector of variable names where the corresponding lengths exceed the threshold.
#' @noRd
.check_exceeds_threshold <- function(variable_names, variable_lengths, threshold) {
  return(
    variable_names[sapply(variable_lengths, function(x) x > threshold)]
  )
}

#' Format Errors
#'
#' Format errors into a character vector with specified prefix.
#'
#' This function formats a list of errors into a character vector with each
#' error message prefixed by a cross.
#'
#' @param errors A list of errors to be formatted.
#' @param disclosure list of disclosure settings, length of number of cohorts
#' @return A character vector containing formatted error messages.
#' @noRd
.format_disclosure_errors <- function(disclosure) {
  out <- c(
    "Error: The maximum length of columns specified in `tidy_select` must be shorter than
           nfilter.string. ", "The values of nfilter.string are: ", disclosure$nfilter.string,
    "{over_filter_thresh} {?is/are} longer than this: "
  )
  names(out) <- c("", "i", "", "i")
  return(out)
}

#' Check tidyverse disclosure Settings
#'
#' @param df.name A character string specifying the name of the dataframe.
#' @param tidy_select A tidy selection specification of columns.
#' @return None. This function is used for its side effects of checking disclosure settings.
#' @noRd
.check_tidy_disclosure <- function(df.name, tidyselect, check_df = TRUE) {
  disc_settings <- listDisclosureSettingsDS()
  if (check_df) {
    .check_data_name_length(df.name, disc_settings)
  }
  .check_function_names(tidyselect)
  .check_variable_length(tidyselect, disc_settings)
}

#' Check that the length of the character string provided to `.data` does not exceed the value of
#' nfilter.string
#'
#' @param .data The data object to be analyzed.
#' @param disclosure list of disclosure settings, length of number of cohorts
#' @noRd
.check_data_name_length <- function(.data, disclosure) {
  data_length <- nchar(.data)
  if (data_length > disclosure$nfilter.string) {
    length_message <- .format_data_length_errors(data_length, disclosure)
    cli_abort(length_message)
  }
}

#' Format errors for `.check_data_name_length`
#'
#' @param data_length The length of the argument to `data`.
#' @param disclosure list of disclosure settings, length of number of cohorts
#' @return A character vector containing the error message.
#' @details The function constructs an error message indicating the length of the string passed to
#' `.data` and the allowed length specified in the `disclosure` argument.
#' @noRd
.format_data_length_errors <- function(data_length, disclosure) {
  out <- c(
    "Error: The length of string passed to `df.name` must be less than nfilter.string.",
    "The value of nfilter.string is: ", disclosure$nfilter.string,
    "The length of `df.name` is: ", data_length
  )
  names(out) <- c("", "i", "", "i", "")
  return(out)
}

#' Check Filter Disclosure Risk
#'
#' This function checks the disclosure risk when applying a filter on a dataset.
#' It evaluates the subset size and the difference in rows between the original
#' and subsetted data to ensure they meet the minimum threshold specified by
#' `nfilter.subset`.
#'
#' @param .data A string representing the name of the original dataset.
#' @param out The filtered dataset object.
#' @keywords internal
#' @return None. The function will throw an error if disclosure risk is detected.
#' @noRd
.check_subset_disclosure_risk <- function(original, out) {
  nfilter.subset <- .get_nfilter_subset_value()
  dims <- .get_dimensions(original, out)
  .check_subset_size(dims$subset, nfilter.subset)
  .check_rows_compared_with_original(dims$original, dims$subset, nfilter.subset)
}

#'
#' @title checkPermissivePrivacyControlLevel
#' @description This server-side function check that the server is running in "permissive" privacy control level.
#' @details Tests whether the R option "datashield.privacyControlLevel" is set to "permissive", if it isn't
#' will cause a call to stop() with the message "BLOCKED: The server is running in 'non-permissive' mode which
#' has caused this method to be blocked".
#' @param privacyControlLevels is a vector of strings which contains the privacy control level names which are permitted by the calling method.
#' @importFrom cli cli_abort
#' @author Wheater, Dr SM., DataSHIELD Team.
#' @return Returns an error if the method is not permitted; otherwise, no value is returned.
#' @export
checkPermissivePrivacyControlLevel <- function(privacyControlLevels){
  disclosureSettings <- listDisclosureSettingsDS()
  if (is.null(disclosureSettings) || is.null(disclosureSettings$datashield.privacyControlLevel) ||
      (! any(disclosureSettings$datashield.privacyControlLevel %in% privacyControlLevels))) {
    cli_abort("BLOCKED: The server is running in 'non-permissive' mode which has caused this method
              to be blocked", call. = TRUE)
  }

  invisible()
}
