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> </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> ".$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>
![[BACK]](/icons/back.gif){kind=icon}
Return to userstatus.pl CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / cgi