WebSVN – VORC – Diff – /trunk/perl/RollerCon.pm

 use DBI;
 use WebDB;
 $SIG{__WARN__} = sub { warn sprintf("[%s] ", scalar localtime), @_ };
+$SIG{__DIE__}  = sub { die  sprintf("[%s] ", scalar localtime), @_ };
+my $SESSIONS = $ENV{SERVER_NAME} eq "volunteers.rollercon.com" ? "/home3/rollerco/vorc_sessions" : "/tmp/sessions";
+my $SESSIONS_ACTIVE = $SESSIONS . "/active";
+my $SESSIONS_QUEUE  = $SESSIONS . "/queue";
+`/bin/mkdir $SESSIONS` unless -e $SESSIONS;
+`/bin/mkdir $SESSIONS_ACTIVE` unless -e $SESSIONS_ACTIVE;
+`/bin/mkdir $SESSIONS_QUEUE`  unless -e $SESSIONS_QUEUE;
+`/usr/bin/find $SESSIONS_ACTIVE -mmin +30 -type f -delete`;
-$SIG{__DIE__}  = sub { die  sprintf("[%s] ", scalar localtime), @_ };
+`/usr/bin/find $SESSIONS_QUEUE -mmin +7 -type f -delete`;
+our @EXPORT = qw( $ORCUSER $SYSTEM_EMAIL getRCDBH getAccessLevels authDB max authenticate canView getShiftDepartment getClassID getDepartments convertDepartments convertTime getSchedule getRCid getSetting getUser getUserEmail getUserDerbyName getYears printRCHeader changeShift modShiftTime signUpCount signUpEligible findConflict changeLeadShift sendNewUserEMail logit validate_emt);
-our @EXPORT = qw( $ORCUSER $SYSTEM_EMAIL getRCDBH getAccessLevels authDB max authenticate canView getShiftDepartment getClassID getDepartments convertDepartments convertTime getSchedule getRCid getSetting getUser getUserEmail getUserDerbyName getYears printRCHeader changeShift modShiftTime signUpCount signUpEligible findConflict changeLeadShift sendNewUserEMail logit validate_emt);
+checkQueue (); # without a number here, the queue functionality is disabled / bypassed
 my $dbh = WebDB->connect ();
 sub getRCDBH {
     my ($max, $next, @vars) = @_;
     return $max if not $next;
     return max( $max > $next ? $max : $next, @vars );
+}
+sub inQueue {
+	my $item = shift;
+	my $array = shift;
+	my $position = 1;
+	foreach (@{$array})	{
+	  if ($item eq $_) {
+		  return $position;
+		} else {
+		  $position++;
+		}
+	}
+	return 0;
+}
 sub authenticate {									# Verifies the user has logged in or puts up a log in screen
 	my $MAINTMODE = getSetting ("MAINTENANCE");
 	my $MINLEVEL = $MAINTMODE ? $MAINTMODE : shift // 1;
 	my ($ERRMSG, $authenticated, %FORM);
 	my $sth = $dbh->prepare("select * from official where email = '?'");
+	my $query = new CGI;
-	my $query = new CGI;
+# Check to see if the user has already logged in (there should be cookies with their authentication)?
-# Check to see if the user has already logged in (there should be cookies with their authentication)?
+	my $RCAUTH = $query->cookie('RCAUTH');
-	my $RCAUTH = $query->cookie('RCAUTH');
+ 	my $RCqueueID = CGI::cookie('RCQUEUEID') // WebDB::trim CGI::param('RCqueueID') // "";
 	$FORM{'ID'} = WebDB::trim $query->param('userid') || '';
+		}
 	} else {
 		$authenticated->{authenticated} = 'false';
+	}
+	if ($authenticated->{authenticated} eq 'true') {
+    use Digest::MD5 qw/md5_hex/;
+    my $sessionid = md5_hex ($ORCUSER->{email});
+    # Limit how long users are allowed to stay logged in at once.
+    my ($session_length) = $dbh->selectrow_array ("select timestampdiff(MINUTE, last_login, now()) from official where RCid = ?", undef, $ORCUSER->{RCid});
+    if ($session_length > getSetting ("MAX_SESSION_MINUTES")) {
+      $ENV{'QUERY_STRING'} = "LOGOUT";
+      $authenticated->{ERRMSG} = "Maximum session time exceeded.<br>";
+    }
+	  if ($ENV{'QUERY_STRING'} eq "LOGOUT") {
+      # warn "logging $ORCUSER->{derby_name} out...";
+      $authenticated->{ERRMSG} .= "Logged Out.<br>";
+      $authenticated->{cookie_string} = "";
+      $authenticated->{authenticated} = 'false';
+      $ENV{REQUEST_URI} =~ s/LOGOUT//;
+      logit ($ORCUSER->{RCid}, "Logged Out");
+      $dbh->do ("update official set last_active = ? where RCid = ?", undef, undef, $ORCUSER->{RCid});
+  		`/bin/rm $SESSIONS_ACTIVE/$sessionid`;
+      $ORCUSER = "";
+    } else {
+  		$dbh->do ("update official set last_active = now() where RCid = ?", undef, $ORCUSER->{RCid});
+  		`/bin/touch $SESSIONS_ACTIVE/$sessionid`;
-	if ($authenticated->{authenticated} eq 'true') {
+      `/bin/rm $SESSIONS_QUEUE/$RCqueueID` if -e $SESSIONS_QUEUE."/".$RCqueueID;
+  		return $authenticated->{cookie_string};
 		return $authenticated->{cookie_string};
-	}
+	}
 # If we get here, the user has failed authentication; throw up the log-in screen and die.
 	my $RCAUTH_cookie = CGI::Cookie->new(-name=>'RCAUTH',-value=>$authenticated->{cookie_string},-expires=>"+30m");
   if ($authenticated->{ERRMSG}) {
   	$authenticated->{ERRMSG} = "<TR><TD colspan=2 align=center><font color=red><b>".$authenticated->{ERRMSG}."</b></font>&nbsp</TD></TR>";
   	# Log the failed access attempt
   } else {
   	$authenticated->{ERRMSG} = "";
+  	# Since there was no ERRMSG, no need to log anything.
+  }
+#	print header(-cookie=>$RCAUTH_cookie);
+  if ($RCqueueID) {
+   	my $RCQUEUE_cookie = CGI::Cookie->new(-name=>'RCQUEUEID',-value=>"",-expires=>"+0m");
-  	# Since there was no ERRMSG, no need to log anything.
+ 	  print header(-cookie=>[$RCAUTH_cookie,$RCQUEUE_cookie]);
   } else {
  	  print header(-cookie=>$RCAUTH_cookie);
+ 	}
-	print header(-cookie=>$RCAUTH_cookie);
+	printRCHeader("Please Sign In");
-	printRCHeader("Please Sign In");
+	print<<authpage;
-	print<<authpage;
+	<form action="$ENV{REQUEST_URI}" method=POST name=Req id=Req>
-	<form action="$ENV{REQUEST_URI}" method=POST name=Req id=Req>
+	<input type=hidden name=RCqueueID value=$RCqueueID>
 		<TR><TD colspan=2 align=center><b><font size=+2>Please Sign In</font>
 		<TABLE>
 		</TD></TR>
+		<TR><TD colspan=2>&nbsp</TD></TR>
+		$authenticated->{ERRMSG}
+authpage
+  if ($ENV{'QUERY_STRING'} eq "LOGOUT") {
+    print "<TR><TD colspan=2>&nbsp</TD></TR>";
+    print "<TR><TD colspan=2><button onClick=\"location.href='';\">Log In</button></TD></TR>";
-		<TR><TD colspan=2>&nbsp</TD></TR>
+    print "</TABLE></BODY></HTML>";
-		$authenticated->{ERRMSG}
+    exit;
 authpage
   if ($authenticated->{authenticated} eq "inactive") {
     print<<activationpage;
       <TR><TD colspan=2 align=center>&nbsp;</TD></TR>
       <TR><TD align=right><B>Activation Code:</TD><TD><INPUT type=text id=activate name=activate></TD></TR>
       <TR><TD></TD><TD><INPUT type=submit name=login value=Submit></TD></TR>
       <TR><TD colspan=2 align=center>&nbsp;</TD></TR>
   		document.getElementById('Req').action = "$ENV{SCRIPT_NAME}";
   		document.getElementById('Req').submit.click();
   		return true;
+  	}
   	//-->
   	</SCRIPT>
 authpage2
+  }
 #foreach (keys %ENV) {
 #	print "$_: $ENV{$_}<br>";
 #}
+#	&JScript;
+	exit;
+}
+sub checkQueue {
+  my $max_users = shift;
+  return unless $max_users =~ /^\d+$/;
+	return if $ENV{'QUERY_STRING'} eq "SKIPQUEUE";
+	my $RCAUTH = CGI::cookie('RCAUTH') // "";
+	if ($RCAUTH) {
+	  # If the user is already logged in, bypass the queue check.
+	  use Digest::MD5 qw/md5_hex/;
+   	my ($RCID, $RCPASS, $RCLVL) = split /&/, $RCAUTH;
+    my $sessionid = md5_hex ($RCID);
+    return if -e $SESSIONS_ACTIVE."/".$sessionid;
+	}
+  my $active_users = `/bin/ls -1 $SESSIONS_ACTIVE | /usr/bin/wc -l`; chomp $active_users;
+  my @queued_users = `/bin/ls -1 $SESSIONS_QUEUE`; foreach (@queued_users) { chomp; }
+ 	my $RCqueueID = CGI::cookie('RCQUEUEID') // WebDB::trim CGI::param('RCqueueID') // "";
+  if ($active_users >= $max_users) {
+    # We are at max users. People have to wait.
+    if (!$RCqueueID) {
+   	  use Digest::MD5 qw/md5_hex/;
+   	  $RCqueueID = time () ."-". md5_hex (rand ());
+   	  push @queued_users, $RCqueueID;
+    }
+ 	  `/bin/touch $SESSIONS_QUEUE/$RCqueueID`;
+    printQueuePage ($RCqueueID, "(".inQueue ($RCqueueID, \@queued_users)." of ".scalar @queued_users." users)");
+    exit;
+  } elsif (scalar @queued_users) {
+    # There are users in queue...
+    if (!$RCqueueID) {
+      # If you're not already in queue, get in line.
+   	  use Digest::MD5 qw/md5_hex/;
+   	  $RCqueueID = time () ."-". md5_hex (rand ());
+   	  push @queued_users, $RCqueueID;
+    }
+ 	  `/bin/touch $SESSIONS_QUEUE/$RCqueueID`;
+   	my $queue_position = inQueue ($RCqueueID, \@queued_users);
+    if ($queue_position > ($max_users - $active_users)) {
+      # If you're not at the head of the line, continue to wait.
+      printQueuePage ($RCqueueID, "($queue_position of ".scalar @queued_users." users)");
+      exit;
+    }
+  }
+  return;
+}
+sub printQueuePage {
+  my $RCqueueID = shift;
+  my $queue_position = shift;
+  print header(-cookie=>CGI::Cookie->new(-name=>'RCQUEUEID',-value=>$RCqueueID,-expires=>"+5m"));
+  printRCHeader("is Busy");
+  print<<busy;
+    <P><b><font size=+2>Sorry, we are full right now.</font></P>
+    <P>You are in queue $queue_position.</P>
+    <div><ul>
+    <li>This page will refresh every 15 seconds.</li>
+    <li>When it's your turn to log in, you'll see the username/password boxes.</li>
+    <li>If you don't log in within five [5] minutes, or if you leave this page, you will likely lose your place in line.</li>
+    </ul></div>
+    </BODY>
+    <SCRIPT language="JavaScript">
+   	<!--
+    // Refresh the page after a delay of 5 seconds
+      setTimeout(function(){
+        location.replace(location.href);
+      }, 15000); // 15000 milliseconds = 15 seconds
+    //-->
+    </SCRIPT>
+    </HTML>
-#	&JScript;
+busy
-	exit;
+  return;
+}
 sub canView {
   return $derbyname;
+}
 sub getSetting {
+	my $k = shift;
 	my $k = shift;
 	my ($value) = $dbh->selectrow_array ("select setting.value from setting where setting.key = ?", undef, $k);
   return defined $value ? $value : undef;
+}
 #  my $logout = $h->a ({ href=>"index.pl", onClick=>"document.cookie = 'RCAUTH=; expires=Thu, 01 Jan 1970 00:00:01 GMT; path=/';return true;" }, "[Log Out]");
   my $referrer = param ("referrer") ? param ("referrer") : $ENV{HTTP_REFERER};
   my $logout = (!$referrer or $referrer eq url) ? "" : $h->button ({ onClick=>"window.location.href='$referrer';" }, "Back")."&nbsp;";
   $logout .= url =~ /\/(index.pl)?$/ ? "" : $h->button ({ onClick=>"window.location.href='/schedule/';" }, "Home")."&nbsp;";
+#  $logout .= $h->button ({ onClick=>"document.cookie = 'RCAUTH=; expires=Thu, 01 Jan 1970 00:00:01 GMT; path=/'; location.href='/';" }, "Log Out");
-  $logout .= $h->button ({ onClick=>"document.cookie = 'RCAUTH=; expires=Thu, 01 Jan 1970 00:00:01 GMT; path=/'; location.href='/';" }, "Log Out");
+  $logout .= $h->button ({ onClick=>"location.href='?LOGOUT';" }, "Log Out");
 	my $loggedinas = $ORCUSER ? "Currently logged in as: ".$h->a ({ href=>"/schedule/view_user.pl?submit=View&RCid=$ORCUSER->{RCid}" }, $ORCUSER->{derby_name}).$h->br.$logout : "";

Subversion Repositories VORC

(root)/trunk/perl/RollerCon.pm – Rev 134 → 138