Annotation of loncom/cgi/userstatus.pl, revision 1.23

1.1       www         1: #!/usr/bin/perl
                      2: $|=1;
                      3: # User Status
1.23    ! raeburn     4: # $Id: userstatus.pl,v 1.22 2021/03/06 19:09:03 raeburn Exp $
1.7       albertel    5: #
                      6: # Copyright Michigan State University Board of Trustees
                      7: #
                      8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                      9: #
                     10: # LON-CAPA is free software; you can redistribute it and/or modify
                     11: # it under the terms of the GNU General Public License as published by
                     12: # the Free Software Foundation; either version 2 of the License, or
                     13: # (at your option) any later version.
                     14: #
                     15: # LON-CAPA is distributed in the hope that it will be useful,
                     16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     18: # GNU General Public License for more details.
                     19: #
                     20: # You should have received a copy of the GNU General Public License
                     21: # along with LON-CAPA; if not, write to the Free Software
                     22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     23: #
                     24: # /home/httpd/html/adm/gpl.txt
                     25: #
                     26: # http://www.lon-capa.org/
                     27: #
                     28: 
1.17      raeburn    29: use strict;
1.1       www        30: 
                     31: use lib '/home/httpd/lib/perl/';
1.17      raeburn    32: use Apache::lonlocal;
1.1       www        33: use LONCAPA::Configuration;
1.17      raeburn    34: use LONCAPA::loncgi;
1.18      raeburn    35: use LONCAPA::lonauthcgi;
1.1       www        36: use HTTP::Headers;
1.15      albertel   37: use GDBM_File;
1.1       www        38: 
1.17      raeburn    39: # -------------------- Read loncapa.conf (and by default, loncapa_apache.conf).
                     40: my $perlvar=&LONCAPA::Configuration::read_conf('loncapa.conf');
1.5       albertel   41: 
1.17      raeburn    42: print "Content-type: text/html\n\n";
1.5       albertel   43: my %usercount;
                     44: my @actl=('Active','Moderately Active','Inactive');
                     45: 
1.17      raeburn    46: &main($perlvar);
1.5       albertel   47: 
                     48: sub analyze_time {
                     49:     my ($since)=@_;
                     50:     my $color="#000000";
                     51:     my $userclass=$actl[0];
1.14      albertel   52:     if ($since>300) { $color="#222222"; $userclass=$actl[1]; }
1.5       albertel   53:     if ($since>600) { $color="#444444"; }
1.14      albertel   54:     if ($since>1800) { $color="#666666"; }
1.5       albertel   55:     if ($since>7200) { $color="#888888"; }
                     56:     if ($since>21600) { $color="#AAAAAA"; $userclass=$actl[2]; }
                     57:     return ($color,$userclass);
                     58: }
                     59: 
                     60: sub add_count {
                     61:     my ($cat,$scope,$class)=@_;
                     62:     if (!defined($usercount{$cat})) {
                     63: 	$usercount{$cat}={};
                     64:     }
                     65:     if (!defined($usercount{$cat}{$scope})) {
                     66: 	$usercount{$cat}{$scope}={};
1.1       www        67:     }
1.5       albertel   68:     $usercount{$cat}{$scope}{$class}++;
1.1       www        69: }
1.5       albertel   70: 
                     71: sub main {
1.17      raeburn    72:     my ($perlvar) = @_;
1.5       albertel   73:     delete $$perlvar{'lonReceipt'}; # remove since sensitive and not needed
                     74:     delete $$perlvar{'lonSqlAccess'}; # remove since sensitive and not needed
                     75: 
1.19      raeburn    76:     if (!&LONCAPA::lonauthcgi::check_ipbased_access('userstatus')) {
1.17      raeburn    77:         if (!&LONCAPA::loncgi::check_cookie_and_load_env()) {
                     78:             &Apache::lonlocal::get_language_handle();
                     79:             print &LONCAPA::loncgi::missing_cookie_msg();
                     80:             return;
                     81:         }
                     82: 
1.18      raeburn    83:         if (!&LONCAPA::lonauthcgi::can_view('userstatus')) {
1.17      raeburn    84:             &Apache::lonlocal::get_language_handle();
1.18      raeburn    85:             print &LONCAPA::lonauthcgi::unauthorized_msg('userstatus');
1.17      raeburn    86:             return;
                     87:         }
                     88:     }
                     89: 
                     90:     &Apache::lonlocal::get_language_handle();
                     91:     my (%gets,$dom,$oneline,$justsummary);
                     92:     &LONCAPA::loncgi::cgi_getitems($ENV{'QUERY_STRING'},\%gets);
                     93:     if (defined($gets{'simple'})) { 
                     94:         $oneline = 'simple'; 
                     95:     } 
                     96:     if (defined($gets{'summary'})) { 
                     97:         $justsummary = 'summary'; 
                     98:     }
                     99:  
                    100:     my %lt = &Apache::lonlocal::texthash(
                    101:                   usrs                => 'User Status',
                    102:                   login               => 'Login time',
                    103:                   on                  => 'on',
                    104:                   Client              => 'Client',
                    105:                   role                => 'Role',
                    106:                   notc                => 'Not in a course',
                    107:                   ltra                => 'Last Transaction',
                    108:                   lacc                => 'Last Access',
                    109:                   secs                => 'secs ago',
                    110:                   usrc                => 'User Counts',
                    111:                   load                => 'Load Average',
                    112:                   Overall             => 'Overall',
                    113:                   Domain              => 'Domain',
                    114:                   Course              => 'Course',
                    115:                   Browser             => 'Browser',
                    116:                   OS                  => 'OS',
1.22      raeburn   117:                   Any                 => 'Any',
1.17      raeburn   118:                   Active              => 'Active',
                    119:                   'Moderately Active' => 'Moderately Active',
                    120:                   Inactive            => 'Inactive',
                    121:             );
                    122:     
                    123:     unless ($oneline) {
                    124:         my $now = time();
1.20      bisitz    125:         print '<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">'."\n".
                    126:               '<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">'."\n"."\n".
                    127:               '<head>'."\n".
                    128:               '<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />'."\n".
                    129:               '<title>LON-CAPA '.$lt{'usrs'}.'</title>'."\n".
                    130:               '</head>'."\n".
                    131:               '<body style="background-color:#FFFFFF">'."\n".
1.17      raeburn   132:               "<h1>$lt{'usrs'} ".&Apache::lonlocal::locallocaltime($now).'</h1>';
                    133:     }
1.5       albertel  134: 
                    135:     opendir(DIR,$$perlvar{'lonIDsDir'});
                    136:     my @allfiles=(sort(readdir(DIR)));
1.14      albertel  137:     my %users;
1.5       albertel  138:     foreach my $filename (@allfiles) {
                    139: 	if ($filename=~/^\./) { next; }
1.12      albertel  140: 	if ($filename=~/^publicuser_/) { next; }
1.21      raeburn   141:         if ($filename=~/^[a-f0-9]+_(linked|lti_\d+)\.id$/) { next; }
1.5       albertel  142: 	my ($dev,$ino,$mode,$nlink,
                    143: 	    $uid,$gid,$rdev,$size,
                    144: 	    $atime,$mtime,$ctime,
                    145: 	    $blksize,$blocks)=stat($$perlvar{'lonIDsDir'}.'/'.$filename);
                    146: 	my $now=time;
                    147: 	my $since=$now-$mtime;
                    148: 	my $sinceacc=$now-$atime;
1.14      albertel  149: 	#unless ($oneline || $justsummary) { print ("\n\n<hr />"); }
1.5       albertel  150: 	my %userinfo;
1.11      albertel  151: 	($userinfo{'user.name'},undef,$userinfo{'user.domain'})=
                    152: 	    split('_',$filename);
1.5       albertel  153: 	my ($color,$userclass)=&analyze_time($since);
                    154: 	&add_count('Overall','all',$userclass);
                    155: 	&add_count('Domain',$userinfo{'user.domain'},$userclass);
                    156: 	
                    157: 	unless ($oneline) {
1.15      albertel  158: 	    if (!tie(%userinfo,'GDBM_File',
                    159: 		     $$perlvar{'lonIDsDir'}.'/'.$filename,
                    160: 		     &GDBM_READER(),0640)) {
                    161: 		next;
1.11      albertel  162: 	    }
1.5       albertel  163: 	    if (!$justsummary) {
1.14      albertel  164: 		$users{$userclass}{$filename} .=
1.20      bisitz    165: 		    '<div style="color:'.$color.'">'.
1.14      albertel  166: 		    '<h3>'.$userinfo{'environment.lastname'}.', '.
1.5       albertel  167: 		    $userinfo{'environment.firstname'}.' '.
                    168: 		    $userinfo{'environment.middlename'}.' '.
                    169: 		    $userinfo{'environment.generation'}." (".
1.20      bisitz    170: 		    $userinfo{'user.name'}.":".$userinfo{'user.domain'}.
1.16      albertel  171: 		    ")</h3>\n".
                    172: 		    "<p><tt>$filename</tt></p>".
1.17      raeburn   173: 		    "<b>$lt{'login'}:</b> ".
                    174: 		    &Apache::lonlocal::locallocaltime($userinfo{'user.login.time'}).
                    175: 		    " <b>$lt{'Browser'}</b>: ".$userinfo{'browser.type'}.
1.20      bisitz    176: 		    " $lt{'on'} ".$userinfo{'browser.os'}." <b>$lt{'Client'}:</b>".
1.17      raeburn   177: 		    $userinfo{'request.host'}."<br />\n<b>$lt{'role'}: </b>".
1.5       albertel  178: 		    $userinfo{'request.role'}." ";
                    179: 	    }
                    180: 	    &add_count('Browser',$userinfo{'browser.type'},$userinfo{'browser.version'});
1.10      albertel  181: 	    &add_count('OS',$userinfo{'browser.os'},$userinfo{'browser.type'});
1.5       albertel  182: 	    if ($userinfo{'request.course.id'}) {
                    183: 		my $cid=$userinfo{'request.course.id'};
                    184: 		my $coursename= $userinfo{'course.'.$cid.'.description'}.
                    185: 		    ' ('.$cid.')';
1.14      albertel  186: 		if (!$justsummary) { 
                    187: 		    $users{$userclass}{$filename} .= 
1.17      raeburn   188: 			"<b>$lt{'Course'}:</b> ".$coursename; 
1.14      albertel  189: 		}
1.5       albertel  190: 		&add_count('Course',$coursename,$userclass);
                    191: 	    } else {
1.14      albertel  192: 		if (!$justsummary) {
1.17      raeburn   193: 		    $users{$userclass}{$filename} .= $lt{'notc'}; 
1.14      albertel  194: 		}
1.5       albertel  195: 		&add_count('Course','No Course',$userclass);
                    196: 	    }
                    197: 	    if (!$justsummary) {
1.14      albertel  198: 		$users{$userclass}{$filename} .=
1.17      raeburn   199: 		    "<br /><b>$lt{'ltra'}:</b> ".&Apache::lonlocal::locallocaltime($mtime).
                    200: 		    " (".$since." $lt{'secs'}) <br /><b>$lt{'lacc'}:</b> ".
                    201: 		    &Apache::lonlocal::locallocaltime($atime)." (".$sinceacc." $lt{'secs'})".
1.20      bisitz    202: 		    "</div>";
1.14      albertel  203: 	    }
                    204: 	}
1.15      albertel  205: 	untie(%userinfo);
1.14      albertel  206:     }
                    207:     if (!$oneline && !$justsummary) {
                    208:        	foreach my $class (@actl) {
1.17      raeburn   209: 	    print("\n\n<hr /><h1>$lt{$class}</h1>");    
1.14      albertel  210: 	    foreach my $filename (sort(keys(%{$users{$class}}))) {
                    211: 		print("\n\n".$users{$class}{$filename}."\n\n<hr />");    
1.5       albertel  212: 	    }
                    213: 	}
                    214:     }
1.14      albertel  215: 
1.5       albertel  216:     closedir(DIR);
                    217:     open (LOADAVGH,"/proc/loadavg");
                    218:     my $loadavg=<LOADAVGH>;
                    219:     close(LOADAVGH);
                    220:     unless ($oneline) { 
1.17      raeburn   221: 	print "<hr /><h2>$lt{'usrc'}</h2>";
1.5       albertel  222: #	print "<pre>\n";
1.17      raeburn   223: 	&showact('Overall',\%lt,%usercount);
                    224: 	&showact('Domain',\%lt,%usercount);
                    225: 	&showact('Course',\%lt,%usercount);
                    226: 	&show('Browser',\%lt,%usercount);
                    227: 	&show('OS',\%lt,%usercount);
1.5       albertel  228: 
                    229: #	print "\n</pre>";
1.20      bisitz    230: 	print "<b>$lt{'load'}:</b> ".$loadavg;
1.5       albertel  231: 	print "</body></html>";
                    232:     } else {
1.6       albertel  233: 	foreach my $l1 (sort keys %usercount) {
                    234: 	    foreach my $l2 (sort keys %{$usercount{$l1}}) {
                    235: 		foreach my $l3 (sort keys %{$usercount{$l1}{$l2}}) {
                    236: 		    print $l1.'_'.$l2.'_'.$l3.'='.$usercount{$l1}{$l2}{$l3}.'&';
                    237: 		}
                    238: 	    }
                    239: 	}
                    240: 	#clusterstatus values
                    241: 	foreach my $act (@actl) {
                    242: 	    print "$act=".$usercount{'Overall'}{'all'}{$act}.'&';
1.5       albertel  243: 	}
                    244: 	print 'loadavg='.$loadavg;
                    245:     }
1.1       www       246: }
1.5       albertel  247: 
                    248: sub show {
1.17      raeburn   249:     my ($cat,$ltref,%usercount)=@_;
                    250:     print("<h3>$ltref->{$cat}</h3>\n");
1.5       albertel  251:     foreach my $type (sort(keys(%{$usercount{$cat}}))) {
                    252: 	print("<table border='1'><tr><th>$type</th><th>");
                    253: 	print(join("</th><th>",sort(keys(%{$usercount{$cat}{$type}}))));
                    254: 	my $temp;
                    255: 	my $count=0;
                    256: 	foreach my $version (sort(keys(%{$usercount{$cat}{$type}}))) {
                    257: 	    $temp.="<td>".$usercount{$cat}{$type}{$version}.
                    258: 		"</td>";
                    259: 	    $count+=$usercount{$cat}{$type}{$version};
                    260: 	}
                    261: 	print("</th></tr><tr><td>$count</td>");
                    262: 	print($temp."</tr></table>\n");
                    263:     }    
1.3       www       264: }
1.5       albertel  265: 
                    266: sub showact {
1.17      raeburn   267:     my ($cat,$ltref,%usercount)=@_;
                    268:     print("<h3>$ltref->{$cat}</h3>\n");
1.5       albertel  269:     
1.20      bisitz    270:     print("<table border='1'><tr><th>&nbsp;</th><th>");
1.23    ! raeburn   271:     print(join("</th><th>",map {$ltref->{$_};} ('Any',@actl)));
1.5       albertel  272:     print("</th></tr>");
                    273:     foreach my $type (sort(keys(%{$usercount{$cat}}))) {
                    274: 	print("<tr><td>$type</td>");
                    275: 	my $temp;
                    276: 	my $count=0;
                    277: 	foreach my $activity (@actl) {
                    278: 	    $temp.="<td>&nbsp;".$usercount{$cat}{$type}{$activity}."</td>";
                    279: 	    $count+=$usercount{$cat}{$type}{$activity};
                    280: 	}
                    281: 	print("<td>$count</td>");
                    282: 	print($temp);
1.20      bisitz    283: 	print('</tr>');
1.5       albertel  284:     }    
1.20      bisitz    285:     print("</table>\n");
1.3       www       286: }
1.5       albertel  287: 

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>