R/psql_store.R

In dakep/stat305templates: STAT 305 Templates for learnr

#' Record `learnr` User-Events in PostgreSQL
#'
#' User-events are saved in a PostgreSQL table in the following format:
#'
#' \describe{
#'   \item{id}{primary key, generated by the database (defined as *SERIAL PRIMARY KEY*)}
#'   \item{timestamp}{timestamp when the event was emitted (defined as *TIMESTAMP DEFAULT CURRENT_TIMESTAMP*)}
#'   \item{tutorial_id}{string identifying the tutorial (defined as *CHARACTER VARYING(255)*)}
#'   \item{tutorial_VERSION}{string identifying the version of the tutorial (defined as *CHARACTER VARYING(255)*)}
#'   \item{user_id}{string identifying user (defined as *CHARACTER VARYING(255)*)}
#'   \item{event}{string identifying the event (defined as *CHARACTER VARYING(255)*)}
#'   \item{data}{event data, stored as JSON (defined as *JSONB*)}
#' }
#'
#' The user id is determined from the current session.
#' See [resume_session] for details on how the user id is determined in the first place.
#'
#' @param what What user-events are to be stored? See https://rstudio.github.io/learnr/publishing.html#recording_events
#'             for available event names.
#' @param db_table Name of the events table.
#' @param db_name Database name. If `NULL`, will be retrieved from `PGDBNAME` or, if unset falls back to the user name.
#' @param db_host,db_port Hostname and port. If `NULL`, will be retrieved from `PGHOST` and `PGPORT` env vars.
#' @param db_user,db_pass User name and password. If `NULL`, will be retrieved from `PGUSER` and `PGPASSWORD` env vars.
#' @param ignore_errors if `TRUE`, ignore database connection errors.
#'
#' @importFrom shiny getDefaultReactiveDomain
#' @importFrom DBI dbClearResult dbConnect dbBegin dbQuoteIdentifier dbSendStatement dbBind dbGetRowsAffected dbRollback
#' @importFrom RPostgres Postgres
#' @importFrom jsonlite toJSON unbox base64_enc serializeJSON
#'
#' @export
setup_psql_event_store <- function (what = c('question_submission', 'exercise_submission', 'exercise_error'),
                                    db_table = 'events', db_user = NULL, db_pass = NULL, db_name = NULL, db_host = NULL,
                                    db_port = NULL, ignore_errors = FALSE) {
  ignore_errors <- isTRUE(ignore_errors)

  get_userid <- function() {
    tryCatch({
      .get_user_id(getDefaultReactiveDomain())
    }, error = function (e) {
      # Shiny does not find the default session. Try manually.
      if(exists('session')) {
        return(.get_user_id(get('session')))
      } else {
        return(NULL)
      }
    })
  }

  if (is.null(db_name)) {
    db_name <- Sys.getenv('PGDBNAME')
    if (db_name == '') {
      db_name <- NULL
    }
  }

  db_conn <- tryCatch(
    dbConnect(Postgres(), dbname = db_name, host = db_host, port = db_port, user = db_user, password = db_pass),
    error = function (e) {
      if (ignore_errors) {
        warning('Can not establish database connection: ', e)
        return(NULL)
      } else {
        stop(e)
      }
    })

  # Check if table exists
  db_table <- tryCatch({
    dbBegin(db_conn)
    test_insert_stmt <- sprintf('INSERT INTO %s (tutorial_id, tutorial_version, user_id, event, data)
                                 VALUES ($1,$2,$3,$4,$5)', dbQuoteIdentifier(db_conn, db_table))
    stmt <- dbSendStatement(db_conn, test_insert_stmt)
    dbBind(stmt, list('tutorial_id', 'tutorial_version', 'user_id', 'event', '{"dummy": true}'))
    dbGetRowsAffected(stmt)
    dbClearResult(stmt)
    dbQuoteIdentifier(db_conn, db_table)
  }, finally = {
    tryCatch(dbRollback(db_conn), error = function (...) {})
  }, error = function (e) {
    if (ignore_errors) {
      warning('Table "', db_table, '" does not exist or is not writable.')
      return(NULL)
    } else {
      stop(paste('Table "', db_table, '" does not seem to exist or is not writable (error: ', e,
                 ').\nCreate the table with:\n',
                 'CREATE TABLE "', db_table, '" (',
                 '\n\tid SERIAL PRIMARY KEY,',
                 '\n\ttimestamp timestamp default current_timestamp,',
                 '\n\ttutorial_id character varying(255),',
                 '\n\ttutorial_version character varying(255),',
                 '\n\tuser_id character varying(255),',
                 '\n\tevent character varying(255),',
                 '\n\tdata jsonb)', collapse = '', sep = ''))
    }
  })

  if (is.null(db_conn) || is.null(db_table)) {
    return(function(...) {})
  }

  insert_stmt_prep <- sprintf('INSERT INTO %s (tutorial_id, tutorial_version, user_id, event, data)
                               VALUES ($1,$2,$3,$4,$5)', db_table)

  event_fun <- function (tutorial_id, tutorial_version, user_id, event, data) {
    if (event %in% what) {
      data$output <- NULL
      user_id <- get_userid()
      if (is.null(user_id)) {
        user_id <- sprintf('anonymous-session-%s', format(Sys.time(), '%Y%m%dT%H%M%S'))
      }

      json_data <- tryCatch(toJSON(data, auto_unbox = TRUE, null = 'null'), error = function (e) {
        toJSON(list(obj = unbox(base64_enc(serialize(data, NULL, ascii = FALSE)))),
                         null = 'null')
      })
      row_data <- list(tutorial_id, tutorial_version, user_id, event, json_data)

      tryCatch({
        stmt <- dbSendStatement(db_conn, insert_stmt_prep)
        tryCatch({
          dbBind(stmt, row_data)
          dbGetRowsAffected(stmt)
        }, error = function (e) {
          stop(e)
        })
        dbClearResult(stmt)
      }, error = function (e) {
        warning('Could not save event data to database:\n\t', e, 'Serialized data: ', serializeJSON(row_data))
      })
    }
  }

  options(tutorial.event_recorder = event_fun)
  return(invisible(NULL))
}