Merge pull request #184 from aappling-usgs/master

changes to session validation/renewal

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: sbtools
 Title: USGS ScienceBase Tools
 Maintainer: Luke Winslow <[email protected]>
-Version: 0.15.2
+Version: 0.15.3
 Authors@R: c(person("Luke", "Winslow", role = c("aut","cre"),
     email = "[email protected]"),
     person("Scott", "Chamberlain", role = c("aut"),

NAMESPACE

@@ -48,10 +48,10 @@ export(sbtools_POST)
 export(sbtools_PUT)
 export(session_age)
 export(session_age_reset)
-export(session_check_reauth)
 export(session_details)
 export(session_expired)
 export(session_logout)
+export(session_renew)
 export(session_validate)
 export(set_endpoint)
 export(set_expiration)

R/REST_helpers.R

@@ -85,7 +85,7 @@ sbtools_DELETE <- function(url, ..., session) {
 
 # HEAD fxn
 sbtools_HEAD <- function(url, ..., session) {
-	check_session(session)
+	session_val(session)
 	r <- HEAD(url = url, ..., handle = session)
 	log <- if (r$status_code == 200) TRUE else FALSE
 	session_age_reset()

R/identifier_exists.R

@@ -8,10 +8,10 @@
 #' @return Logical, \code{TRUE} or \code{FALSE}
 #' @examples \dontrun{
 #' # identifier exists
-#' identifier_exists(id = "4f4e4b24e4b07f02db6aea14")
+#' identifier_exists(sb_id = "4f4e4b24e4b07f02db6aea14")
 #' 
 #' # identifier does not exist
-#' identifier_exists(id = "aaaaaaakkkkkkkbbbbbb")
+#' identifier_exists(sb_id = "aaaaaaakkkkkkkbbbbbb")
 #' }
 identifier_exists <- function(sb_id, ..., session = current_session()) {
 	sb_id = as.sbitem(sb_id)

R/is_logged_in.R

@@ -8,5 +8,5 @@
 #' is_logged_in()
 #' }
 is_logged_in <- function(..., session = current_session()) {
-	session_details(..., session = session)$isLoggedIn
+	!is.null(session) && session_details(..., session = session)$isLoggedIn
 }

R/session_renew.R

@@ -0,0 +1,58 @@
+#' Checks current session and re-authenticates if necessary
+#' 
+#' Checks the state of your Sciencebase session, re-authenticates if the session
+#' is expired, and simply renews if the session is active.
+#' 
+#' @param password The password to use, if needed, to renew the session.
+#' @param username Optional. Used only to confirm that the current username is 
+#'   what you expect; if you want to switch usernames, use 
+#'   \code{authenticate_sb()} instead of this function.
+#' @param session SB session object from \code{\link{authenticate_sb}}. Default 
+#'   is the current session.
+#' @param ... Any additional parameters are currently ignored.
+#'   
+#' @return Returns the session object.
+#'   
+#' @examples
+#' \dontrun{
+#' # an empty call is sufficient if the session is current, 
+#' # but will break if haven't been logged in before
+#' session_renew()
+#' 
+#' # include a password if session may be expired
+#' session_renew('newpass')
+#' 
+#' # optionally confirm the value of the current username
+#' session_renew(username='[email protected]', 'newpass')
+#' }
+#' @import httr
+#' @export
+session_renew = function(password, ..., username, session=current_session()){
+
+	# if we'll need the current username, find it now. use the existing session
+	# info on SB if available; otherwise use the username stored locally
+	if(!missing(username) || !is_logged_in(session=session)) {
+		sb_username <- session_details(session=session)$username
+		if(is.null(sb_username)) sb_username <- pkg.env$username
+	}
+
+	# if username is provided, confirm that it matches the stored username
+	if(!missing(username)) {
+		if(username != sb_username) {
+			stop("username argument does not match session username")
+		}
+	}
+
+	# either renew or re-authenticate as needed
+	if(is_logged_in(session=session)) {
+		# the GET call to 'status' resets the remote (SB) info on session age, while 
+		# sbtools_GET resets the local info on session age
+		sbtools_GET(url=paste0(pkg.env$url_base, "status?format=json"), session=session)
+		invisible(session)
+	} else {
+		# re-authenticate, handling missing parameters as needed
+		if(sb_username=="") stop("new authentication is necessary; call authenticate_sb()")
+		if(missing(password)) stop("re-authentication is necessary; need password")
+		invisible(authenticate_sb(sb_username, password))
+	}
+}

tests/testthat/test-eg.R

@@ -6,7 +6,6 @@ test_that("session validation works appropriately", {
 	session <- httr::handle("http://google.com")
 	attributes(session) <- c(attributes(session), list(birthdate=Sys.time()))
 	expect_true(session_validate(session))
-	expect_is(session_check_reauth(session), 'handle')
 	set_expiration(as.difftime("00:00:01"))
 	Sys.sleep(2)
 	expect_false(session_validate(session))