Annotation of loncom/lonnet/perl/lonnet.pm, revision 1.195
1.1 albertel 1: # The LearningOnline Network
2: # TCP networking package
1.12 www 3: #
1.194 www 4: # $Id: lonnet.pm,v 1.193 2001/12/22 21:46:02 www Exp $
1.178 www 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: #
1.169 harris41 28: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
29: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
30: # 11/8,11/16,11/18,11/22,11/23,12/22,
31: # 01/06,01/13,02/24,02/28,02/29,
32: # 03/01,03/02,03/06,03/07,03/13,
33: # 04/05,05/29,05/31,06/01,
34: # 06/05,06/26 Gerd Kortemeyer
35: # 06/26 Ben Tyszka
36: # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
37: # 08/14 Ben Tyszka
38: # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
39: # 10/04 Gerd Kortemeyer
40: # 10/04 Guy Albertelli
41: # 10/06,10/09,10/10,10/11,10/14,10/20,10/23,10/25,10/26,10/27,10/28,10/29,
42: # 10/30,10/31,
43: # 11/2,11/14,11/15,11/16,11/20,11/21,11/22,11/25,11/27,
44: # 12/02,12/12,12/13,12/14,12/28,12/29 Gerd Kortemeyer
45: # 05/01/01 Guy Albertelli
46: # 05/01,06/01,09/01 Gerd Kortemeyer
47: # 09/01 Guy Albertelli
48: # 09/01,10/01,11/01 Gerd Kortemeyer
49: # YEAR=2001
50: # 02/27/01 Scott Harrison
51: # 3/2 Gerd Kortemeyer
52: # 3/15,3/19 Scott Harrison
53: # 3/19,3/20 Gerd Kortemeyer
54: # 3/22,3/27,4/2,4/16,4/17 Scott Harrison
55: # 5/26,5/28 Gerd Kortemeyer
56: # 5/30 H. K. Ng
57: # 6/1 Gerd Kortemeyer
58: # July Guy Albertelli
59: # 8/4,8/7,8/8,8/9,8/11,8/16,8/17,8/18,8/20,8/23,9/20,9/21,9/26,
60: # 10/2 Gerd Kortemeyer
61: # 10/5,10/10,11/13,11/15 Scott Harrison
1.179 www 62: # 11/17,11/20,11/22,11/29 Gerd Kortemeyer
1.182 matthew 63: # 12/5 Matthew Hall
1.184 www 64: # 12/5 Guy Albertelli
1.190 www 65: # 12/6,12/7,12/12 Gerd Kortemeyer
1.191 harris41 66: # 12/18 Scott Harrison
1.195 ! www 67: # 12/21,12/22,12/27,12/28 Gerd Kortemeyer
1.171 www 68: #
1.169 harris41 69: ###
70:
1.1 albertel 71: package Apache::lonnet;
72:
73: use strict;
74: use Apache::File;
1.8 www 75: use LWP::UserAgent();
1.15 www 76: use HTTP::Headers;
1.11 www 77: use vars
1.188 www 78: qw(%perlvar %hostname %homecache %hostip %spareid %hostdom
1.192 www 79: %libserv %pr %prp %metacache %packagetab
1.188 www 80: %courselogs %accesshash $processmarker $dumpcount
81: %coursedombuf %coursehombuf);
1.1 albertel 82: use IO::Socket;
1.31 www 83: use GDBM_File;
1.8 www 84: use Apache::Constants qw(:common :http);
1.71 www 85: use HTML::TokeParser;
1.88 www 86: use Fcntl qw(:flock);
1.195 ! www 87: my $readit;
1.1 albertel 88:
89: # --------------------------------------------------------------------- Logging
90:
1.163 harris41 91: sub logtouch {
92: my $execdir=$perlvar{'lonDaemons'};
93: unless (-e "$execdir/logs/lonnet.log") {
94: my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
95: close $fh;
96: }
97: my ($wwwuid,$wwwgid)=(getpwnam('www'))[2,3];
98: chown($wwwuid,$wwwgid,$execdir.'/logs/lonnet.log');
99: }
100:
1.1 albertel 101: sub logthis {
102: my $message=shift;
103: my $execdir=$perlvar{'lonDaemons'};
104: my $now=time;
105: my $local=localtime($now);
1.162 harris41 106: my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
107: print $fh "$local ($$): $message\n";
1.1 albertel 108: return 1;
109: }
110:
111: sub logperm {
112: my $message=shift;
113: my $execdir=$perlvar{'lonDaemons'};
114: my $now=time;
115: my $local=localtime($now);
1.162 harris41 116: my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");
117: print $fh "$now:$message:$local\n";
1.1 albertel 118: return 1;
119: }
120:
121: # -------------------------------------------------- Non-critical communication
122: sub subreply {
123: my ($cmd,$server)=@_;
124: my $peerfile="$perlvar{'lonSockDir'}/$server";
125: my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
126: Type => SOCK_STREAM,
127: Timeout => 10)
128: or return "con_lost";
129: print $client "$cmd\n";
130: my $answer=<$client>;
1.9 www 131: if (!$answer) { $answer="con_lost"; }
1.1 albertel 132: chomp($answer);
133: return $answer;
134: }
135:
136: sub reply {
137: my ($cmd,$server)=@_;
138: my $answer=subreply($cmd,$server);
139: if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
1.65 www 140: if (($answer=~/^refused/) || ($answer=~/^rejected/)) {
1.12 www 141: &logthis("<font color=blue>WARNING:".
142: " $cmd to $server returned $answer</font>");
143: }
1.1 albertel 144: return $answer;
145: }
146:
147: # ----------------------------------------------------------- Send USR1 to lonc
148:
149: sub reconlonc {
150: my $peerfile=shift;
151: &logthis("Trying to reconnect for $peerfile");
152: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
153: if (my $fh=Apache::File->new("$loncfile")) {
154: my $loncpid=<$fh>;
155: chomp($loncpid);
156: if (kill 0 => $loncpid) {
157: &logthis("lonc at pid $loncpid responding, sending USR1");
158: kill USR1 => $loncpid;
159: sleep 1;
160: if (-e "$peerfile") { return; }
161: &logthis("$peerfile still not there, give it another try");
162: sleep 5;
163: if (-e "$peerfile") { return; }
1.12 www 164: &logthis(
165: "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
1.1 albertel 166: } else {
1.12 www 167: &logthis(
168: "<font color=blue>WARNING:".
169: " lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 170: }
171: } else {
1.12 www 172: &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
1.1 albertel 173: }
174: }
175:
176: # ------------------------------------------------------ Critical communication
1.12 www 177:
1.1 albertel 178: sub critical {
179: my ($cmd,$server)=@_;
1.89 www 180: unless ($hostname{$server}) {
181: &logthis("<font color=blue>WARNING:".
182: " Critical message to unknown server ($server)</font>");
183: return 'no_such_host';
184: }
1.1 albertel 185: my $answer=reply($cmd,$server);
186: if ($answer eq 'con_lost') {
187: my $pingreply=reply('ping',$server);
188: &reconlonc("$perlvar{'lonSockDir'}/$server");
189: my $pongreply=reply('pong',$server);
190: &logthis("Ping/Pong for $server: $pingreply/$pongreply");
191: $answer=reply($cmd,$server);
192: if ($answer eq 'con_lost') {
193: my $now=time;
194: my $middlename=$cmd;
1.5 www 195: $middlename=substr($middlename,0,16);
1.1 albertel 196: $middlename=~s/\W//g;
197: my $dfilename=
198: "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";
199: {
200: my $dfh;
201: if ($dfh=Apache::File->new(">$dfilename")) {
1.7 www 202: print $dfh "$cmd\n";
1.1 albertel 203: }
204: }
205: sleep 2;
206: my $wcmd='';
207: {
208: my $dfh;
209: if ($dfh=Apache::File->new("$dfilename")) {
210: $wcmd=<$dfh>;
211: }
212: }
213: chomp($wcmd);
1.7 www 214: if ($wcmd eq $cmd) {
1.12 www 215: &logthis("<font color=blue>WARNING: ".
216: "Connection buffer $dfilename: $cmd</font>");
1.1 albertel 217: &logperm("D:$server:$cmd");
218: return 'con_delayed';
219: } else {
1.12 www 220: &logthis("<font color=red>CRITICAL:"
221: ." Critical connection failed: $server $cmd</font>");
1.1 albertel 222: &logperm("F:$server:$cmd");
223: return 'con_failed';
224: }
225: }
226: }
227: return $answer;
228: }
229:
1.5 www 230: # ---------------------------------------------------------- Append Environment
231:
232: sub appenv {
1.6 www 233: my %newenv=@_;
1.191 harris41 234: foreach (keys %newenv) {
1.35 www 235: if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
236: &logthis("<font color=blue>WARNING: ".
1.151 www 237: "Attempt to modify environment ".$_." to ".$newenv{$_}
238: .'</font>');
1.35 www 239: delete($newenv{$_});
240: } else {
241: $ENV{$_}=$newenv{$_};
242: }
1.191 harris41 243: }
1.95 www 244:
245: my $lockfh;
246: unless ($lockfh=Apache::File->new("$ENV{'user.environment'}")) {
1.97 www 247: return 'error: '.$!;
1.95 www 248: }
249: unless (flock($lockfh,LOCK_EX)) {
250: &logthis("<font color=blue>WARNING: ".
251: 'Could not obtain exclusive lock in appenv: '.$!);
252: $lockfh->close();
253: return 'error: '.$!;
254: }
255:
1.6 www 256: my @oldenv;
257: {
258: my $fh;
259: unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
1.97 www 260: return 'error: '.$!;
1.6 www 261: }
262: @oldenv=<$fh>;
1.89 www 263: $fh->close();
1.6 www 264: }
265: for (my $i=0; $i<=$#oldenv; $i++) {
266: chomp($oldenv[$i]);
1.9 www 267: if ($oldenv[$i] ne '') {
268: my ($name,$value)=split(/=/,$oldenv[$i]);
1.24 www 269: unless (defined($newenv{$name})) {
270: $newenv{$name}=$value;
271: }
1.9 www 272: }
1.6 www 273: }
274: {
275: my $fh;
276: unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
277: return 'error';
278: }
279: my $newname;
1.93 www 280: foreach $newname (keys %newenv) {
1.6 www 281: print $fh "$newname=$newenv{$newname}\n";
282: }
1.86 albertel 283: $fh->close();
1.56 www 284: }
1.95 www 285:
286: $lockfh->close();
1.56 www 287: return 'ok';
288: }
289: # ----------------------------------------------------- Delete from Environment
290:
291: sub delenv {
292: my $delthis=shift;
293: my %newenv=();
294: if (($delthis=~/user\.role/) || ($delthis=~/user\.priv/)) {
295: &logthis("<font color=blue>WARNING: ".
296: "Attempt to delete from environment ".$delthis);
297: return 'error';
298: }
299: my @oldenv;
300: {
301: my $fh;
302: unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
303: return 'error';
304: }
1.89 www 305: unless (flock($fh,LOCK_SH)) {
306: &logthis("<font color=blue>WARNING: ".
307: 'Could not obtain shared lock in delenv: '.$!);
308: $fh->close();
309: return 'error: '.$!;
310: }
1.56 www 311: @oldenv=<$fh>;
1.89 www 312: $fh->close();
1.56 www 313: }
314: {
315: my $fh;
316: unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
317: return 'error';
318: }
1.89 www 319: unless (flock($fh,LOCK_EX)) {
320: &logthis("<font color=blue>WARNING: ".
321: 'Could not obtain exclusive lock in delenv: '.$!);
322: $fh->close();
323: return 'error: '.$!;
324: }
1.191 harris41 325: foreach (@oldenv) {
1.56 www 326: unless ($_=~/^$delthis/) { print $fh $_; }
1.191 harris41 327: }
1.87 www 328: $fh->close();
1.5 www 329: }
330: return 'ok';
331: }
1.1 albertel 332:
333: # ------------------------------ Find server with least workload from spare.tab
1.11 www 334:
1.1 albertel 335: sub spareserver {
336: my $tryserver;
337: my $spareserver='';
338: my $lowestserver=100;
339: foreach $tryserver (keys %spareid) {
340: my $answer=reply('load',$tryserver);
341: if (($answer =~ /\d/) && ($answer<$lowestserver)) {
342: $spareserver="http://$hostname{$tryserver}";
343: $lowestserver=$answer;
344: }
345: }
346: return $spareserver;
347: }
348:
1.169 harris41 349: # ----------------------- Try to determine user's current authentication scheme
350:
351: sub queryauthenticate {
352: my ($uname,$udom)=@_;
353: if (($perlvar{'lonRole'} eq 'library') &&
354: ($udom eq $perlvar{'lonDefDomain'})) {
355: my $answer=reply("encrypt:currentauth:$udom:$uname",
356: $perlvar{'lonHostID'});
357: unless ($answer eq 'unknown_user' or $answer eq 'refused') {
358: if (length($answer)) {
359: return $answer;
360: }
361: else {
362: &logthis("User $uname at $udom lacks an authentication mechanism");
363: return 'no_host';
364: }
365: }
366: }
367:
368: my $tryserver;
369: foreach $tryserver (keys %libserv) {
370: if ($hostdom{$tryserver} eq $udom) {
371: my $answer=reply("encrypt:currentauth:$udom:$uname",$tryserver);
372: unless ($answer eq 'unknown_user' or $answer eq 'refused') {
373: if (length($answer)) {
374: return $answer;
375: }
376: else {
377: &logthis("User $uname at $udom lacks an authentication mechanism");
378: return 'no_host';
379: }
380: }
381: }
382: }
383: &logthis("User $uname at $udom lacks an authentication mechanism");
384: return 'no_host';
385: }
386:
1.1 albertel 387: # --------- Try to authenticate user from domain's lib servers (first this one)
1.11 www 388:
1.1 albertel 389: sub authenticate {
390: my ($uname,$upass,$udom)=@_;
1.12 www 391: $upass=escape($upass);
1.1 albertel 392: if (($perlvar{'lonRole'} eq 'library') &&
393: ($udom eq $perlvar{'lonDefDomain'})) {
1.3 www 394: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
1.2 www 395: if ($answer =~ /authorized/) {
1.9 www 396: if ($answer eq 'authorized') {
397: &logthis("User $uname at $udom authorized by local server");
398: return $perlvar{'lonHostID'};
399: }
400: if ($answer eq 'non_authorized') {
401: &logthis("User $uname at $udom rejected by local server");
402: return 'no_host';
403: }
1.2 www 404: }
1.1 albertel 405: }
406:
407: my $tryserver;
408: foreach $tryserver (keys %libserv) {
409: if ($hostdom{$tryserver} eq $udom) {
1.10 www 410: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
1.1 albertel 411: if ($answer =~ /authorized/) {
1.9 www 412: if ($answer eq 'authorized') {
413: &logthis("User $uname at $udom authorized by $tryserver");
414: return $tryserver;
415: }
416: if ($answer eq 'non_authorized') {
417: &logthis("User $uname at $udom rejected by $tryserver");
418: return 'no_host';
419: }
1.1 albertel 420: }
421: }
1.9 www 422: }
423: &logthis("User $uname at $udom could not be authenticated");
1.1 albertel 424: return 'no_host';
425: }
426:
427: # ---------------------- Find the homebase for a user from domain's lib servers
1.11 www 428:
1.1 albertel 429: sub homeserver {
430: my ($uname,$udom)=@_;
431:
432: my $index="$uname:$udom";
433: if ($homecache{$index}) { return "$homecache{$index}"; }
434:
435: my $tryserver;
436: foreach $tryserver (keys %libserv) {
437: if ($hostdom{$tryserver} eq $udom) {
438: my $answer=reply("home:$udom:$uname",$tryserver);
439: if ($answer eq 'found') {
440: $homecache{$index}=$tryserver;
441: return $tryserver;
442: }
443: }
444: }
445: return 'no_host';
1.70 www 446: }
447:
448: # ------------------------------------- Find the usernames behind a list of IDs
449:
450: sub idget {
451: my ($udom,@ids)=@_;
452: my %returnhash=();
453:
454: my $tryserver;
455: foreach $tryserver (keys %libserv) {
456: if ($hostdom{$tryserver} eq $udom) {
457: my $idlist=join('&',@ids);
458: $idlist=~tr/A-Z/a-z/;
459: my $reply=&reply("idget:$udom:".$idlist,$tryserver);
460: my @answer=();
1.76 www 461: if (($reply ne 'con_lost') && ($reply!~/^error\:/)) {
1.70 www 462: @answer=split(/\&/,$reply);
463: } ;
464: my $i;
465: for ($i=0;$i<=$#ids;$i++) {
466: if ($answer[$i]) {
467: $returnhash{$ids[$i]}=$answer[$i];
468: }
469: }
470: }
471: }
472: return %returnhash;
473: }
474:
475: # ------------------------------------- Find the IDs behind a list of usernames
476:
477: sub idrget {
478: my ($udom,@unames)=@_;
479: my %returnhash=();
1.191 harris41 480: foreach (@unames) {
1.70 www 481: $returnhash{$_}=(&userenvironment($udom,$_,'id'))[1];
1.191 harris41 482: }
1.70 www 483: return %returnhash;
484: }
485:
486: # ------------------------------- Store away a list of names and associated IDs
487:
488: sub idput {
489: my ($udom,%ids)=@_;
490: my %servers=();
1.191 harris41 491: foreach (keys %ids) {
1.70 www 492: my $uhom=&homeserver($_,$udom);
493: if ($uhom ne 'no_host') {
494: my $id=&escape($ids{$_});
495: $id=~tr/A-Z/a-z/;
496: my $unam=&escape($_);
497: if ($servers{$uhom}) {
498: $servers{$uhom}.='&'.$id.'='.$unam;
499: } else {
500: $servers{$uhom}=$id.'='.$unam;
501: }
502: &critical('put:'.$udom.':'.$unam.':environment:id='.$id,$uhom);
503: }
1.191 harris41 504: }
505: foreach (keys %servers) {
1.70 www 506: &critical('idput:'.$udom.':'.$servers{$_},$_);
1.191 harris41 507: }
1.70 www 508: }
509:
510: # ------------------------------------- Find the section of student in a course
511:
512: sub usection {
513: my ($udom,$unam,$courseid)=@_;
514: $courseid=~s/\_/\//g;
515: $courseid=~s/^(\w)/\/$1/;
1.191 harris41 516: foreach (split(/\&/,&reply('dump:'.$udom.':'.$unam.':roles',
517: &homeserver($unam,$udom)))) {
1.70 www 518: my ($key,$value)=split(/\=/,$_);
519: $key=&unescape($key);
520: if ($key=~/^$courseid(?:\/)*(\w+)*\_st$/) {
521: my $section=$1;
522: if ($key eq $courseid.'_st') { $section=''; }
523: my ($dummy,$end,$start)=split(/\_/,&unescape($value));
524: my $now=time;
525: my $notactive=0;
526: if ($start) {
527: if ($now<$start) { $notactive=1; }
528: }
529: if ($end) {
530: if ($now>$end) { $notactive=1; }
531: }
532: unless ($notactive) { return $section; }
533: }
1.191 harris41 534: }
1.70 www 535: return '-1';
536: }
537:
538: # ------------------------------------- Read an entry from a user's environment
539:
540: sub userenvironment {
541: my ($udom,$unam,@what)=@_;
542: my %returnhash=();
543: my @answer=split(/\&/,
544: &reply('get:'.$udom.':'.$unam.':environment:'.join('&',@what),
545: &homeserver($unam,$udom)));
546: my $i;
547: for ($i=0;$i<=$#what;$i++) {
548: $returnhash{$what[$i]}=&unescape($answer[$i]);
549: }
550: return %returnhash;
1.1 albertel 551: }
552:
553: # ----------------------------- Subscribe to a resource, return URL if possible
1.11 www 554:
1.1 albertel 555: sub subscribe {
556: my $fname=shift;
557: my $author=$fname;
558: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
559: my ($udom,$uname)=split(/\//,$author);
560: my $home=homeserver($uname,$udom);
561: if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) {
562: return 'not_found';
563: }
564: my $answer=reply("sub:$fname",$home);
1.64 www 565: if (($answer eq 'con_lost') || ($answer eq 'rejected')) {
566: $answer.=' by '.$home;
567: }
1.1 albertel 568: return $answer;
569: }
570:
1.8 www 571: # -------------------------------------------------------------- Replicate file
572:
573: sub repcopy {
574: my $filename=shift;
1.23 www 575: $filename=~s/\/+/\//g;
1.8 www 576: my $transname="$filename.in.transfer";
1.17 www 577: if ((-e $filename) || (-e $transname)) { return OK; }
1.8 www 578: my $remoteurl=subscribe($filename);
1.64 www 579: if ($remoteurl =~ /^con_lost by/) {
580: &logthis("Subscribe returned $remoteurl: $filename");
1.8 www 581: return HTTP_SERVICE_UNAVAILABLE;
582: } elsif ($remoteurl eq 'not_found') {
583: &logthis("Subscribe returned not_found: $filename");
584: return HTTP_NOT_FOUND;
1.64 www 585: } elsif ($remoteurl =~ /^rejected by/) {
586: &logthis("Subscribe returned $remoteurl: $filename");
1.8 www 587: return FORBIDDEN;
1.20 www 588: } elsif ($remoteurl eq 'directory') {
589: return OK;
1.8 www 590: } else {
591: my @parts=split(/\//,$filename);
592: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
593: if ($path ne "$perlvar{'lonDocRoot'}/res") {
594: &logthis("Malconfiguration for replication: $filename");
595: return HTTP_BAD_REQUEST;
596: }
597: my $count;
598: for ($count=5;$count<$#parts;$count++) {
599: $path.="/$parts[$count]";
600: if ((-e $path)!=1) {
601: mkdir($path,0777);
602: }
603: }
604: my $ua=new LWP::UserAgent;
605: my $request=new HTTP::Request('GET',"$remoteurl");
606: my $response=$ua->request($request,$transname);
607: if ($response->is_error()) {
608: unlink($transname);
609: my $message=$response->status_line;
1.12 www 610: &logthis("<font color=blue>WARNING:"
611: ." LWP get: $message: $filename</font>");
1.8 www 612: return HTTP_SERVICE_UNAVAILABLE;
613: } else {
1.16 www 614: if ($remoteurl!~/\.meta$/) {
615: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
616: my $mresponse=$ua->request($mrequest,$filename.'.meta');
617: if ($mresponse->is_error()) {
618: unlink($filename.'.meta');
619: &logthis(
620: "<font color=yellow>INFO: No metadata: $filename</font>");
621: }
622: }
1.8 www 623: rename($transname,$filename);
624: return OK;
625: }
626: }
627: }
628:
1.15 www 629: # --------------------------------------------------------- Server Side Include
630:
631: sub ssi {
632:
1.23 www 633: my ($fn,%form)=@_;
1.15 www 634:
635: my $ua=new LWP::UserAgent;
1.23 www 636:
637: my $request;
638:
639: if (%form) {
640: $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
641: $request->content(join '&', map { "$_=$form{$_}" } keys %form);
642: } else {
643: $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
644: }
645:
1.15 www 646: $request->header(Cookie => $ENV{'HTTP_COOKIE'});
647: my $response=$ua->request($request);
648:
649: return $response->content;
650: }
651:
1.14 www 652: # ------------------------------------------------------------------------- Log
653:
654: sub log {
655: my ($dom,$nam,$hom,$what)=@_;
1.47 www 656: return critical("log:$dom:$nam:$what",$hom);
1.157 www 657: }
658:
659: # ------------------------------------------------------------------ Course Log
660:
661: sub flushcourselogs {
662: &logthis('Flushing course log buffers');
1.191 harris41 663: foreach (keys %courselogs) {
1.157 www 664: my $crsid=$_;
1.188 www 665: if (&reply('log:'.$coursedombuf{$crsid}.':'.
666: &escape($courselogs{$crsid}),
667: $coursehombuf{$crsid}) eq 'ok') {
1.157 www 668: delete $courselogs{$crsid};
669: } else {
670: &logthis('Failed to flush log buffer for '.$crsid);
671: if (length($courselogs{$crsid})>40000) {
672: &logthis("<font color=blue>WARNING: Buffer for ".$crsid.
673: " exceeded maximum size, deleting.</font>");
674: delete $courselogs{$crsid};
675: }
676: }
1.191 harris41 677: }
1.185 www 678: &logthis('Flushing access logs');
1.191 harris41 679: foreach (keys %accesshash) {
1.185 www 680: my $entry=$_;
681: $entry=~/\_\_\_(\w+)\/(\w+)\/(.*)\_\_\_(\w+)$/;
682: my %temphash=($entry => $accesshash{$entry});
683: if (&Apache::lonnet::put('resevaldata',\%temphash,$1,$2) eq 'ok') {
684: delete $accesshash{$entry};
685: }
1.191 harris41 686: }
1.186 www 687: $dumpcount++;
1.157 www 688: }
689:
690: sub courselog {
691: my $what=shift;
1.158 www 692: $what=time.':'.$what;
1.157 www 693: unless ($ENV{'request.course.id'}) { return ''; }
1.188 www 694: $coursedombuf{$ENV{'request.course.id'}}=
695: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
696: $ENV{'course.'.$ENV{'request.course.id'}.'.num'};
697: $coursehombuf{$ENV{'request.course.id'}}=
698: $ENV{'course.'.$ENV{'request.course.id'}.'.home'};
1.157 www 699: if (defined $courselogs{$ENV{'request.course.id'}}) {
700: $courselogs{$ENV{'request.course.id'}}.='&'.$what;
701: } else {
702: $courselogs{$ENV{'request.course.id'}}.=$what;
703: }
704: if (length($courselogs{$ENV{'request.course.id'}})>4048) {
705: &flushcourselogs();
706: }
1.158 www 707: }
708:
709: sub courseacclog {
710: my $fnsymb=shift;
711: unless ($ENV{'request.course.id'}) { return ''; }
712: my $what=$fnsymb.':'.$ENV{'user.name'}.':'.$ENV{'user.domain'};
1.192 www 713: if ($fnsymb=~/(problem|exam|quiz|assess|survey|form)$/) {
1.187 www 714: $what.=':POST';
1.191 harris41 715: foreach (keys %ENV) {
1.158 www 716: if ($_=~/^form\.(.*)/) {
717: $what.=':'.$1.'='.$ENV{$_};
718: }
1.191 harris41 719: }
1.158 www 720: }
721: &courselog($what);
1.149 www 722: }
723:
1.185 www 724: sub countacc {
725: my $url=&declutter(shift);
726: unless ($ENV{'request.course.id'}) { return ''; }
727: $accesshash{$ENV{'request.course.id'}.'___'.$url.'___course'}=1;
1.186 www 728: my $key=$processmarker.'_'.$dumpcount.'___'.$url.'___count';
1.185 www 729: if (defined($accesshash{$key})) {
730: $accesshash{$key}++;
731: } else {
732: $accesshash{$key}=1;
733: }
734: }
735:
1.149 www 736: # ----------------------------------------------------------- Check out an item
737:
738: sub checkout {
739: my ($symb,$tuname,$tudom,$tcrsid)=@_;
740: my $now=time;
741: my $lonhost=$perlvar{'lonHostID'};
742: my $infostr=&escape(
743: $tuname.'&'.
744: $tudom.'&'.
745: $tcrsid.'&'.
746: $symb.'&'.
747: $now.'&'.$ENV{'REMOTE_ADDR'});
748: my $token=&reply('tmpput:'.$infostr,$lonhost);
1.151 www 749: if ($token=~/^error\:/) {
750: &logthis("<font color=blue>WARNING: ".
751: "Checkout tmpput failed ".$tudom.' - '.$tuname.' - '.$symb.
752: "</font>");
753: return '';
754: }
755:
1.149 www 756: $token=~s/^(\d+)\_.*\_(\d+)$/$1\*$2\*$lonhost/;
757: $token=~tr/a-z/A-Z/;
758:
1.153 www 759: my %infohash=('resource.0.outtoken' => $token,
760: 'resource.0.checkouttime' => $now,
761: 'resource.0.outremote' => $ENV{'REMOTE_ADDR'});
1.149 www 762:
763: unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
764: return '';
1.151 www 765: } else {
766: &logthis("<font color=blue>WARNING: ".
767: "Checkout cstore failed ".$tudom.' - '.$tuname.' - '.$symb.
768: "</font>");
1.149 www 769: }
770:
771: if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
772: &escape('Checkout '.$infostr.' - '.
773: $token)) ne 'ok') {
774: return '';
1.151 www 775: } else {
776: &logthis("<font color=blue>WARNING: ".
777: "Checkout log failed ".$tudom.' - '.$tuname.' - '.$symb.
778: "</font>");
1.149 www 779: }
1.151 www 780: return $token;
1.149 www 781: }
782:
783: # ------------------------------------------------------------ Check in an item
784:
785: sub checkin {
786: my $token=shift;
1.150 www 787: my $now=time;
788: my ($ta,$tb,$lonhost)=split(/\*/,$token);
789: $lonhost=~tr/A-Z/a-z/;
790: my $dtoken=$ta.'_'.$hostip{$lonhost}.'_'.$tb;
791: $dtoken=~s/\W/\_/g;
792: my ($tuname,$tudom,$tcrsid,$symb,$chtim,$rmaddr)=
793: split(/\&/,&unescape(&reply('tmpget:'.$dtoken,$lonhost)));
794:
1.154 www 795: unless (($tuname) && ($tudom)) {
796: &logthis('Check in '.$token.' ('.$dtoken.') failed');
797: return '';
798: }
799:
800: unless (&allowed('mgr',$tcrsid)) {
801: &logthis('Check in '.$token.' ('.$dtoken.') unauthorized: '.
802: $ENV{'user.name'}.' - '.$ENV{'user.domain'});
803: return '';
804: }
805:
1.153 www 806: my %infohash=('resource.0.intoken' => $token,
807: 'resource.0.checkintime' => $now,
808: 'resource.0.inremote' => $ENV{'REMOTE_ADDR'});
1.150 www 809:
810: unless (&cstore(\%infohash,$symb,$tcrsid,$tudom,$tuname) eq 'ok') {
811: return '';
812: }
813:
814: if (&log($tudom,$tuname,&homeserver($tuname,$tudom),
815: &escape('Checkin - '.$token)) ne 'ok') {
816: return '';
817: }
818:
819: return ($symb,$tuname,$tudom,$tcrsid);
1.110 www 820: }
821:
822: # --------------------------------------------- Set Expire Date for Spreadsheet
823:
824: sub expirespread {
825: my ($uname,$udom,$stype,$usymb)=@_;
826: my $cid=$ENV{'request.course.id'};
827: if ($cid) {
828: my $now=time;
829: my $key=$uname.':'.$udom.':'.$stype.':'.$usymb;
830: return &reply('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
831: $ENV{'course.'.$cid.'.num'}.
832: ':nohist_expirationdates:'.
833: &escape($key).'='.$now,
834: $ENV{'course.'.$cid.'.home'})
835: }
836: return 'ok';
1.14 www 837: }
838:
1.109 www 839: # ----------------------------------------------------- Devalidate Spreadsheets
840:
841: sub devalidate {
842: my $symb=shift;
843: my $cid=$ENV{'request.course.id'};
844: if ($cid) {
845: my $key=$ENV{'user.name'}.':'.$ENV{'user.domain'}.':';
846: my $status=
1.133 albertel 847: &del('nohist_calculatedsheet',
848: [$key.'studentcalc'],
849: $ENV{'course.'.$cid.'.domain'},
850: $ENV{'course.'.$cid.'.num'})
851: .' '.
852: &del('nohist_calculatedsheets_'.$cid,
853: [$key.'assesscalc:'.$symb]);
1.109 www 854: unless ($status eq 'ok ok') {
855: &logthis('Could not devalidate spreadsheet '.
856: $ENV{'user.name'}.' at '.$ENV{'user.domain'}.' for '.
857: $symb.': '.$status);
1.133 albertel 858: }
1.109 www 859: }
860: }
861:
1.168 albertel 862: sub hash2str {
863: my (%hash)=@_;
864: my $result='';
1.191 harris41 865: foreach (keys %hash) { $result.=escape($_).'='.escape($hash{$_}).'&'; }
1.168 albertel 866: $result=~s/\&$//;
867: return $result;
868: }
869:
870: sub str2hash {
871: my ($string) = @_;
872: my %returnhash;
1.191 harris41 873: foreach (split(/\&/,$string)) {
1.168 albertel 874: my ($name,$value)=split(/\=/,$_);
875: $returnhash{&unescape($name)}=&unescape($value);
1.191 harris41 876: }
1.168 albertel 877: return %returnhash;
878: }
879:
1.167 albertel 880: # -------------------------------------------------------------------Temp Store
881:
1.168 albertel 882: sub tmpreset {
883: my ($symb,$namespace,$domain,$stuname) = @_;
884: if (!$symb) {
885: $symb=&symbread();
886: if (!$symb) { $symb= $ENV{'REQUEST_URI'}; }
887: }
888: $symb=escape($symb);
889:
890: if (!$namespace) { $namespace=$ENV{'request.state'}; }
891: $namespace=~s/\//\_/g;
892: $namespace=~s/\W//g;
893:
894: #FIXME needs to do something for /pub resources
895: if (!$domain) { $domain=$ENV{'user.domain'}; }
896: if (!$stuname) { $stuname=$ENV{'user.name'}; }
897: my $path=$perlvar{'lonDaemons'}.'/tmp';
898: my %hash;
899: if (tie(%hash,'GDBM_File',
900: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
901: &GDBM_WRCREAT,0640)) {
902: foreach my $key (keys %hash) {
1.180 albertel 903: if ($key=~ /:$symb/) {
1.168 albertel 904: delete($hash{$key});
905: }
906: }
907: }
908: }
909:
1.167 albertel 910: sub tmpstore {
1.168 albertel 911: my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
912:
913: if (!$symb) {
914: $symb=&symbread();
915: if (!$symb) { $symb= $ENV{'request.url'}; }
916: }
917: $symb=escape($symb);
918:
919: if (!$namespace) {
920: # I don't think we would ever want to store this for a course.
921: # it seems this will only be used if we don't have a course.
922: #$namespace=$ENV{'request.course.id'};
923: #if (!$namespace) {
924: $namespace=$ENV{'request.state'};
925: #}
926: }
927: $namespace=~s/\//\_/g;
928: $namespace=~s/\W//g;
929: #FIXME needs to do something for /pub resources
930: if (!$domain) { $domain=$ENV{'user.domain'}; }
931: if (!$stuname) { $stuname=$ENV{'user.name'}; }
932: my $now=time;
933: my %hash;
934: my $path=$perlvar{'lonDaemons'}.'/tmp';
935: if (tie(%hash,'GDBM_File',
936: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
937: &GDBM_WRCREAT,0640)) {
938: $hash{"version:$symb"}++;
939: my $version=$hash{"version:$symb"};
940: my $allkeys='';
941: foreach my $key (keys(%$storehash)) {
942: $allkeys.=$key.':';
943: $hash{"$version:$symb:$key"}=$$storehash{$key};
944: }
945: $hash{"$version:$symb:timestamp"}=$now;
946: $allkeys.='timestamp';
947: $hash{"$version:keys:$symb"}=$allkeys;
948: if (untie(%hash)) {
949: return 'ok';
950: } else {
951: return "error:$!";
952: }
953: } else {
954: return "error:$!";
955: }
956: }
1.167 albertel 957:
1.168 albertel 958: # -----------------------------------------------------------------Temp Restore
1.167 albertel 959:
1.168 albertel 960: sub tmprestore {
961: my ($symb,$namespace,$domain,$stuname) = @_;
1.167 albertel 962:
1.168 albertel 963: if (!$symb) {
964: $symb=&symbread();
965: if (!$symb) { $symb= $ENV{'request.url'}; }
966: }
967: $symb=escape($symb);
968:
969: if (!$namespace) { $namespace=$ENV{'request.state'}; }
970: #FIXME needs to do something for /pub resources
971: if (!$domain) { $domain=$ENV{'user.domain'}; }
972: if (!$stuname) { $stuname=$ENV{'user.name'}; }
973:
974: my %returnhash;
975: $namespace=~s/\//\_/g;
976: $namespace=~s/\W//g;
977: my %hash;
978: my $path=$perlvar{'lonDaemons'}.'/tmp';
979: if (tie(%hash,'GDBM_File',
980: $path.'/tmpstore_'.$stuname.'_'.$domain.'_'.$namespace.'.db',
981: &GDBM_READER,0640)) {
982: my $version=$hash{"version:$symb"};
983: $returnhash{'version'}=$version;
984: my $scope;
985: for ($scope=1;$scope<=$version;$scope++) {
986: my $vkeys=$hash{"$scope:keys:$symb"};
987: my @keys=split(/:/,$vkeys);
988: my $key;
989: $returnhash{"$scope:keys"}=$vkeys;
990: foreach $key (@keys) {
991: $returnhash{"$scope:$key"}=$hash{"$scope:$symb:$key"};
992: $returnhash{"$key"}=$hash{"$scope:$symb:$key"};
1.167 albertel 993: }
994: }
1.168 albertel 995: if (!(untie(%hash))) {
996: return "error:$!";
997: }
998: } else {
999: return "error:$!";
1000: }
1001: return %returnhash;
1.167 albertel 1002: }
1003:
1.9 www 1004: # ----------------------------------------------------------------------- Store
1005:
1006: sub store {
1.124 www 1007: my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
1008: my $home='';
1009:
1.168 albertel 1010: if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124 www 1011:
1.122 albertel 1012: if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109 www 1013:
1014: &devalidate($symb);
1015:
1016: $symb=escape($symb);
1.187 www 1017: if (!$namespace) {
1018: unless ($namespace=$ENV{'request.course.id'}) {
1019: return '';
1020: }
1021: }
1.122 albertel 1022: if (!$domain) { $domain=$ENV{'user.domain'}; }
1023: if (!$stuname) { $stuname=$ENV{'user.name'}; }
1024: if (!$home) { $home=$ENV{'user.home'}; }
1.12 www 1025: my $namevalue='';
1.191 harris41 1026: foreach (keys %$storehash) {
1.122 albertel 1027: $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
1.191 harris41 1028: }
1.12 www 1029: $namevalue=~s/\&$//;
1.187 www 1030: &courselog($symb.':'.$stuname.':'.$domain.':STORE:'.$namevalue);
1.124 www 1031: return reply("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.9 www 1032: }
1033:
1.47 www 1034: # -------------------------------------------------------------- Critical Store
1035:
1036: sub cstore {
1.124 www 1037: my ($storehash,$symb,$namespace,$domain,$stuname) = @_;
1038: my $home='';
1039:
1.168 albertel 1040: if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124 www 1041:
1.122 albertel 1042: if (!$symb) { unless ($symb=&symbread()) { return ''; } }
1.109 www 1043:
1044: &devalidate($symb);
1045:
1046: $symb=escape($symb);
1.187 www 1047: if (!$namespace) {
1048: unless ($namespace=$ENV{'request.course.id'}) {
1049: return '';
1050: }
1051: }
1.122 albertel 1052: if (!$domain) { $domain=$ENV{'user.domain'}; }
1053: if (!$stuname) { $stuname=$ENV{'user.name'}; }
1054: if (!$home) { $home=$ENV{'user.home'}; }
1055:
1.47 www 1056: my $namevalue='';
1.191 harris41 1057: foreach (keys %$storehash) {
1.122 albertel 1058: $namevalue.=escape($_).'='.escape($$storehash{$_}).'&';
1.191 harris41 1059: }
1.47 www 1060: $namevalue=~s/\&$//;
1.187 www 1061: &courselog($symb.':'.$stuname.':'.$domain.':CSTORE:'.$namevalue);
1.188 www 1062: return critical
1063: ("store:$domain:$stuname:$namespace:$symb:$namevalue","$home");
1.47 www 1064: }
1065:
1.9 www 1066: # --------------------------------------------------------------------- Restore
1067:
1068: sub restore {
1.124 www 1069: my ($symb,$namespace,$domain,$stuname) = @_;
1070: my $home='';
1071:
1.168 albertel 1072: if ($stuname) { $home=&homeserver($stuname,$domain); }
1.124 www 1073:
1.122 albertel 1074: if (!$symb) {
1075: unless ($symb=escape(&symbread())) { return ''; }
1076: } else {
1077: $symb=&escape($symb);
1078: }
1.188 www 1079: if (!$namespace) {
1080: unless ($namespace=$ENV{'request.course.id'}) {
1081: return '';
1082: }
1083: }
1.122 albertel 1084: if (!$domain) { $domain=$ENV{'user.domain'}; }
1085: if (!$stuname) { $stuname=$ENV{'user.name'}; }
1086: if (!$home) { $home=$ENV{'user.home'}; }
1087: my $answer=&reply("restore:$domain:$stuname:$namespace:$symb","$home");
1088:
1.12 www 1089: my %returnhash=();
1.191 harris41 1090: foreach (split(/\&/,$answer)) {
1.12 www 1091: my ($name,$value)=split(/\=/,$_);
1092: $returnhash{&unescape($name)}=&unescape($value);
1.191 harris41 1093: }
1.75 www 1094: my $version;
1095: for ($version=1;$version<=$returnhash{'version'};$version++) {
1.191 harris41 1096: foreach (split(/\:/,$returnhash{$version.':keys'})) {
1.75 www 1097: $returnhash{$_}=$returnhash{$version.':'.$_};
1.191 harris41 1098: }
1.75 www 1099: }
1.13 www 1100: return %returnhash;
1.34 www 1101: }
1102:
1103: # ---------------------------------------------------------- Course Description
1104:
1105: sub coursedescription {
1106: my $courseid=shift;
1107: $courseid=~s/^\///;
1.49 www 1108: $courseid=~s/\_/\//g;
1.34 www 1109: my ($cdomain,$cnum)=split(/\//,$courseid);
1.129 albertel 1110: my $chome=&homeserver($cnum,$cdomain);
1.34 www 1111: if ($chome ne 'no_host') {
1.129 albertel 1112: my %returnhash=&dump('environment',$cdomain,$cnum);
1113: if (!exists($returnhash{'con_lost'})) {
1.96 www 1114: my $normalid=$cdomain.'_'.$cnum;
1.53 www 1115: my %envhash=();
1.129 albertel 1116: $returnhash{'home'}= $chome;
1117: $returnhash{'domain'} = $cdomain;
1118: $returnhash{'num'} = $cnum;
1.130 albertel 1119: while (my ($name,$value) = each %returnhash) {
1.53 www 1120: $envhash{'course.'.$normalid.'.'.$name}=$value;
1.129 albertel 1121: }
1.34 www 1122: $returnhash{'url'}='/res/'.declutter($returnhash{'url'});
1123: $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
1.38 www 1124: $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
1.54 www 1125: $envhash{'course.'.$normalid.'.last_cache'}=time;
1.60 www 1126: $envhash{'course.'.$normalid.'.home'}=$chome;
1127: $envhash{'course.'.$normalid.'.domain'}=$cdomain;
1128: $envhash{'course.'.$normalid.'.num'}=$cnum;
1.53 www 1129: &appenv(%envhash);
1.34 www 1130: return %returnhash;
1131: }
1132: }
1133: return ();
1.9 www 1134: }
1.1 albertel 1135:
1.103 harris41 1136: # -------------------------------------------------------- Get user privileges
1.11 www 1137:
1138: sub rolesinit {
1139: my ($domain,$username,$authhost)=@_;
1140: my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12 www 1141: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11 www 1142: my %allroles=();
1143: my %thesepriv=();
1144: my $now=time;
1.21 www 1145: my $userroles="user.login.time=$now\n";
1.11 www 1146: my $thesestr;
1147:
1148: if ($rolesdump ne '') {
1.191 harris41 1149: foreach (split(/&/,$rolesdump)) {
1.21 www 1150: if ($_!~/^rolesdef\&/) {
1.11 www 1151: my ($area,$role)=split(/=/,$_);
1.21 www 1152: $area=~s/\_\w\w$//;
1.11 www 1153: my ($trole,$tend,$tstart)=split(/_/,$role);
1.21 www 1154: $userroles.='user.role.'.$trole.'.'.$area.'='.
1155: $tstart.'.'.$tend."\n";
1.11 www 1156: if ($tend!=0) {
1157: if ($tend<$now) {
1158: $trole='';
1159: }
1160: }
1161: if ($tstart!=0) {
1162: if ($tstart>$now) {
1163: $trole='';
1164: }
1165: }
1166: if (($area ne '') && ($trole ne '')) {
1.50 www 1167: my $spec=$trole.'.'.$area;
1.12 www 1168: my ($tdummy,$tdomain,$trest)=split(/\//,$area);
1169: if ($trole =~ /^cr\//) {
1170: my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
1171: my $homsvr=homeserver($rauthor,$rdomain);
1172: if ($hostname{$homsvr} ne '') {
1173: my $roledef=
1.21 www 1174: reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
1.12 www 1175: $homsvr);
1176: if (($roledef ne 'con_lost') && ($roledef ne '')) {
1177: my ($syspriv,$dompriv,$coursepriv)=
1.21 www 1178: split(/\_/,unescape($roledef));
1.50 www 1179: $allroles{'cm./'}.=':'.$syspriv;
1180: $allroles{$spec.'./'}.=':'.$syspriv;
1.12 www 1181: if ($tdomain ne '') {
1.50 www 1182: $allroles{'cm./'.$tdomain.'/'}.=':'.$dompriv;
1183: $allroles{$spec.'./'.$tdomain.'/'}.=':'.$dompriv;
1.12 www 1184: if ($trest ne '') {
1.50 www 1185: $allroles{'cm.'.$area}.=':'.$coursepriv;
1186: $allroles{$spec.'.'.$area}.=':'.$coursepriv;
1.12 www 1187: }
1188: }
1189: }
1.11 www 1190: }
1.12 www 1191: } else {
1.50 www 1192: $allroles{'cm./'}.=':'.$pr{$trole.':s'};
1193: $allroles{$spec.'./'}.=':'.$pr{$trole.':s'};
1.12 www 1194: if ($tdomain ne '') {
1.50 www 1195: $allroles{'cm./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
1196: $allroles{$spec.'./'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
1.12 www 1197: if ($trest ne '') {
1.50 www 1198: $allroles{'cm.'.$area}.=':'.$pr{$trole.':c'};
1199: $allroles{$spec.'.'.$area}.=':'.$pr{$trole.':c'};
1.12 www 1200: }
1201: }
1.11 www 1202: }
1.12 www 1203: }
1204: }
1.191 harris41 1205: }
1.125 www 1206: my $adv=0;
1.128 www 1207: my $author=0;
1.191 harris41 1208: foreach (keys %allroles) {
1.11 www 1209: %thesepriv=();
1.146 www 1210: if (($_!~/^st/) && ($_!~/^ta/) && ($_!~/^cm/)) { $adv=1; }
1.128 www 1211: if (($_=~/^au/) || ($_=~/^ca/)) { $author=1; }
1.191 harris41 1212: foreach (split(/:/,$allroles{$_})) {
1.11 www 1213: if ($_ ne '') {
1.103 harris41 1214: my ($privilege,$restrictions)=split(/&/,$_);
1.11 www 1215: if ($restrictions eq '') {
1.103 harris41 1216: $thesepriv{$privilege}='F';
1.11 www 1217: } else {
1.103 harris41 1218: if ($thesepriv{$privilege} ne 'F') {
1219: $thesepriv{$privilege}.=$restrictions;
1.11 www 1220: }
1221: }
1222: }
1.191 harris41 1223: }
1.11 www 1224: $thesestr='';
1.191 harris41 1225: foreach (keys %thesepriv) { $thesestr.=':'.$_.'&'.$thesepriv{$_}; }
1.11 www 1226: $userroles.='user.priv.'.$_.'='.$thesestr."\n";
1.191 harris41 1227: }
1.128 www 1228: $userroles.='user.adv='.$adv."\n".
1229: 'user.author='.$author."\n";
1.126 www 1230: $ENV{'user.adv'}=$adv;
1.11 www 1231: }
1232: return $userroles;
1233: }
1234:
1.12 www 1235: # --------------------------------------------------------------- get interface
1236:
1237: sub get {
1.131 albertel 1238: my ($namespace,$storearr,$udomain,$uname)=@_;
1.12 www 1239: my $items='';
1.191 harris41 1240: foreach (@$storearr) {
1.12 www 1241: $items.=escape($_).'&';
1.191 harris41 1242: }
1.12 www 1243: $items=~s/\&$//;
1.131 albertel 1244: if (!$udomain) { $udomain=$ENV{'user.domain'}; }
1245: if (!$uname) { $uname=$ENV{'user.name'}; }
1246: my $uhome=&homeserver($uname,$udomain);
1247:
1.133 albertel 1248: my $rep=&reply("get:$udomain:$uname:$namespace:$items",$uhome);
1.15 www 1249: my @pairs=split(/\&/,$rep);
1250: my %returnhash=();
1.42 www 1251: my $i=0;
1.191 harris41 1252: foreach (@$storearr) {
1.42 www 1253: $returnhash{$_}=unescape($pairs[$i]);
1254: $i++;
1.191 harris41 1255: }
1.15 www 1256: return %returnhash;
1.27 www 1257: }
1258:
1259: # --------------------------------------------------------------- del interface
1260:
1261: sub del {
1.133 albertel 1262: my ($namespace,$storearr,$udomain,$uname)=@_;
1.27 www 1263: my $items='';
1.191 harris41 1264: foreach (@$storearr) {
1.27 www 1265: $items.=escape($_).'&';
1.191 harris41 1266: }
1.27 www 1267: $items=~s/\&$//;
1.133 albertel 1268: if (!$udomain) { $udomain=$ENV{'user.domain'}; }
1269: if (!$uname) { $uname=$ENV{'user.name'}; }
1270: my $uhome=&homeserver($uname,$udomain);
1271:
1272: return &reply("del:$udomain:$uname:$namespace:$items",$uhome);
1.15 www 1273: }
1274:
1275: # -------------------------------------------------------------- dump interface
1276:
1277: sub dump {
1.193 www 1278: my ($namespace,$udomain,$uname,$regexp)=@_;
1.129 albertel 1279: if (!$udomain) { $udomain=$ENV{'user.domain'}; }
1280: if (!$uname) { $uname=$ENV{'user.name'}; }
1281: my $uhome=&homeserver($uname,$udomain);
1.193 www 1282: if ($regexp) {
1283: $regexp=&escape($regexp);
1284: } else {
1285: $regexp='.';
1286: }
1287: my $rep=reply("dump:$udomain:$uname:$namespace:$regexp",$uhome);
1.12 www 1288: my @pairs=split(/\&/,$rep);
1289: my %returnhash=();
1.191 harris41 1290: foreach (@pairs) {
1.12 www 1291: my ($key,$value)=split(/=/,$_);
1.29 www 1292: $returnhash{unescape($key)}=unescape($value);
1.191 harris41 1293: }
1.12 www 1294: return %returnhash;
1295: }
1296:
1297: # --------------------------------------------------------------- put interface
1298:
1299: sub put {
1.134 albertel 1300: my ($namespace,$storehash,$udomain,$uname)=@_;
1301: if (!$udomain) { $udomain=$ENV{'user.domain'}; }
1302: if (!$uname) { $uname=$ENV{'user.name'}; }
1303: my $uhome=&homeserver($uname,$udomain);
1.12 www 1304: my $items='';
1.191 harris41 1305: foreach (keys %$storehash) {
1.134 albertel 1306: $items.=&escape($_).'='.&escape($$storehash{$_}).'&';
1.191 harris41 1307: }
1.12 www 1308: $items=~s/\&$//;
1.134 albertel 1309: return &reply("put:$udomain:$uname:$namespace:$items",$uhome);
1.47 www 1310: }
1311:
1312: # ------------------------------------------------------ critical put interface
1313:
1314: sub cput {
1.134 albertel 1315: my ($namespace,$storehash,$udomain,$uname)=@_;
1316: if (!$udomain) { $udomain=$ENV{'user.domain'}; }
1317: if (!$uname) { $uname=$ENV{'user.name'}; }
1318: my $uhome=&homeserver($uname,$udomain);
1.47 www 1319: my $items='';
1.191 harris41 1320: foreach (keys %$storehash) {
1.134 albertel 1321: $items.=escape($_).'='.escape($$storehash{$_}).'&';
1.191 harris41 1322: }
1.47 www 1323: $items=~s/\&$//;
1.134 albertel 1324: return &critical("put:$udomain:$uname:$namespace:$items",$uhome);
1.12 www 1325: }
1326:
1327: # -------------------------------------------------------------- eget interface
1328:
1329: sub eget {
1.133 albertel 1330: my ($namespace,$storearr,$udomain,$uname)=@_;
1.12 www 1331: my $items='';
1.191 harris41 1332: foreach (@$storearr) {
1.12 www 1333: $items.=escape($_).'&';
1.191 harris41 1334: }
1.12 www 1335: $items=~s/\&$//;
1.133 albertel 1336: if (!$udomain) { $udomain=$ENV{'user.domain'}; }
1337: if (!$uname) { $uname=$ENV{'user.name'}; }
1338: my $uhome=&homeserver($uname,$udomain);
1339: my $rep=&reply("eget:$udomain:$uname:$namespace:$items",$uhome);
1.12 www 1340: my @pairs=split(/\&/,$rep);
1341: my %returnhash=();
1.42 www 1342: my $i=0;
1.191 harris41 1343: foreach (@$storearr) {
1.42 www 1344: $returnhash{$_}=unescape($pairs[$i]);
1345: $i++;
1.191 harris41 1346: }
1.12 www 1347: return %returnhash;
1348: }
1349:
1.103 harris41 1350: # ------------------------------------------------- Check for a user privilege
1.12 www 1351:
1352: sub allowed {
1353: my ($priv,$uri)=@_;
1.152 www 1354:
1355: my $orguri=$uri;
1.52 www 1356: $uri=&declutter($uri);
1.29 www 1357:
1.54 www 1358: # Free bre access to adm and meta resources
1.29 www 1359:
1.54 www 1360: if ((($uri=~/^adm\//) || ($uri=~/\.meta$/)) && ($priv eq 'bre')) {
1.14 www 1361: return 'F';
1.159 www 1362: }
1363:
1364: # Free bre to public access
1365:
1366: if ($priv eq 'bre') {
1367: if (&metadata($uri,'copyright') eq 'public') { return 'F'; }
1.14 www 1368: }
1.29 www 1369:
1.52 www 1370: my $thisallowed='';
1371: my $statecond=0;
1372: my $courseprivid='';
1373:
1374: # Course
1375:
1376: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'}=~/$priv\&([^\:]*)/) {
1377: $thisallowed.=$1;
1378: }
1.29 www 1379:
1.52 www 1380: # Domain
1381:
1382: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.(split(/\//,$uri))[0].'/'}
1383: =~/$priv\&([^\:]*)/) {
1.12 www 1384: $thisallowed.=$1;
1385: }
1.52 www 1386:
1387: # Course: uri itself is a course
1.66 www 1388: my $courseuri=$uri;
1389: $courseuri=~s/\_(\d)/\/$1/;
1.83 www 1390: $courseuri=~s/^([^\/])/\/$1/;
1.81 www 1391:
1.83 www 1392: if ($ENV{'user.priv.'.$ENV{'request.role'}.'.'.$courseuri}
1.52 www 1393: =~/$priv\&([^\:]*)/) {
1.12 www 1394: $thisallowed.=$1;
1395: }
1.29 www 1396:
1.52 www 1397: # Full access at system, domain or course-wide level? Exit.
1.29 www 1398:
1399: if ($thisallowed=~/F/) {
1400: return 'F';
1401: }
1402:
1.52 www 1403: # If this is generating or modifying users, exit with special codes
1.29 www 1404:
1.166 www 1405: if (':csu:cdc:ccc:cin:cta:cep:ccr:cst:cad:cli:cau:cdg:cca:'=~/\:$priv\:/) {
1.52 www 1406: return $thisallowed;
1407: }
1408: #
1.103 harris41 1409: # Gathered so far: system, domain and course wide privileges
1.52 www 1410: #
1411: # Course: See if uri or referer is an individual resource that is part of
1412: # the course
1413:
1414: if ($ENV{'request.course.id'}) {
1415: $courseprivid=$ENV{'request.course.id'};
1416: if ($ENV{'request.course.sec'}) {
1417: $courseprivid.='/'.$ENV{'request.course.sec'};
1418: }
1419: $courseprivid=~s/\_/\//;
1420: my $checkreferer=1;
1421: my @uriparts=split(/\//,$uri);
1422: my $filename=$uriparts[$#uriparts];
1423: my $pathname=$uri;
1424: $pathname=~s/\/$filename$//;
1425: if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
1.54 www 1426: /\&$filename\:([\d\|]+)\&/) {
1.52 www 1427: $statecond=$1;
1428: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
1429: =~/$priv\&([^\:]*)/) {
1430: $thisallowed.=$1;
1431: $checkreferer=0;
1432: }
1.29 www 1433: }
1.83 www 1434:
1.148 www 1435: if ($checkreferer) {
1.152 www 1436: my $refuri=$ENV{'httpref.'.$orguri};
1.148 www 1437:
1438: unless ($refuri) {
1.191 harris41 1439: foreach (keys %ENV) {
1.148 www 1440: if ($_=~/^httpref\..*\*/) {
1441: my $pattern=$_;
1.156 www 1442: $pattern=~s/^httpref\.\/res\///;
1.148 www 1443: $pattern=~s/\*/\[\^\/\]\+/g;
1444: $pattern=~s/\//\\\//g;
1.152 www 1445: if ($orguri=~/$pattern/) {
1.148 www 1446: $refuri=$ENV{$_};
1447: }
1448: }
1.191 harris41 1449: }
1.148 www 1450: }
1451: if ($refuri) {
1.152 www 1452: $refuri=&declutter($refuri);
1.53 www 1453: my @uriparts=split(/\//,$refuri);
1.52 www 1454: my $filename=$uriparts[$#uriparts];
1.53 www 1455: my $pathname=$refuri;
1.52 www 1456: $pathname=~s/\/$filename$//;
1.53 www 1457: if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$pathname}=~
1.54 www 1458: /\&$filename\:([\d\|]+)\&/) {
1.53 www 1459: my $refstatecond=$1;
1.52 www 1460: if ($ENV{'user.priv.'.$ENV{'request.role'}.'./'.$courseprivid}
1461: =~/$priv\&([^\:]*)/) {
1462: $thisallowed.=$1;
1.53 www 1463: $uri=$refuri;
1464: $statecond=$refstatecond;
1.52 www 1465: }
1466: }
1.148 www 1467: }
1.29 www 1468: }
1.52 www 1469: }
1.29 www 1470:
1.52 www 1471: #
1.103 harris41 1472: # Gathered now: all privileges that could apply, and condition number
1.52 www 1473: #
1474: #
1475: # Full or no access?
1476: #
1.29 www 1477:
1.52 www 1478: if ($thisallowed=~/F/) {
1479: return 'F';
1480: }
1.29 www 1481:
1.52 www 1482: unless ($thisallowed) {
1483: return '';
1484: }
1.29 www 1485:
1.52 www 1486: # Restrictions exist, deal with them
1487: #
1488: # C:according to course preferences
1489: # R:according to resource settings
1490: # L:unless locked
1491: # X:according to user session state
1492: #
1493:
1494: # Possibly locked functionality, check all courses
1.54 www 1495: # Locks might take effect only after 10 minutes cache expiration for other
1496: # courses, and 2 minutes for current course
1.52 www 1497:
1498: my $envkey;
1499: if ($thisallowed=~/L/) {
1500: foreach $envkey (keys %ENV) {
1.54 www 1501: if ($envkey=~/^user\.role\.(st|ta)\.([^\.]*)/) {
1502: my $courseid=$2;
1503: my $roleid=$1.'.'.$2;
1.92 www 1504: $courseid=~s/^\///;
1.54 www 1505: my $expiretime=600;
1506: if ($ENV{'request.role'} eq $roleid) {
1507: $expiretime=120;
1508: }
1509: my ($cdom,$cnum,$csec)=split(/\//,$courseid);
1510: my $prefix='course.'.$cdom.'_'.$cnum.'.';
1511: if ((time-$ENV{$prefix.'last_cache'})>$expiretime) {
1512: &coursedescription($courseid);
1513: }
1514: if (($ENV{$prefix.'res.'.$uri.'.lock.sections'}=~/\,$csec\,/)
1515: || ($ENV{$prefix.'res.'.$uri.'.lock.sections'} eq 'all')) {
1516: if ($ENV{$prefix.'res.'.$uri.'.lock.expire'}>time) {
1.57 www 1517: &log($ENV{'user.domain'},$ENV{'user.name'},
1518: $ENV{'user.host'},
1519: 'Locked by res: '.$priv.' for '.$uri.' due to '.
1.52 www 1520: $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54 www 1521: $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52 www 1522: return '';
1523: }
1524: }
1.54 www 1525: if (($ENV{$prefix.'priv.'.$priv.'.lock.sections'}=~/\,$csec\,/)
1526: || ($ENV{$prefix.'priv.'.$priv.'.lock.sections'} eq 'all')) {
1527: if ($ENV{'priv.'.$priv.'.lock.expire'}>time) {
1.57 www 1528: &log($ENV{'user.domain'},$ENV{'user.name'},
1529: $ENV{'user.host'},
1530: 'Locked by priv: '.$priv.' for '.$uri.' due to '.
1.52 www 1531: $cdom.'/'.$cnum.'/'.$csec.' expire '.
1.54 www 1532: $ENV{$prefix.'priv.'.$priv.'.lock.expire'});
1.52 www 1533: return '';
1534: }
1535: }
1536: }
1.29 www 1537: }
1.52 www 1538: }
1539:
1540: #
1541: # Rest of the restrictions depend on selected course
1542: #
1543:
1544: unless ($ENV{'request.course.id'}) {
1545: return '1';
1546: }
1.29 www 1547:
1.52 www 1548: #
1549: # Now user is definitely in a course
1550: #
1.53 www 1551:
1552:
1553: # Course preferences
1554:
1555: if ($thisallowed=~/C/) {
1.54 www 1556: my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
1557: if ($ENV{'course.'.$ENV{'request.course.id'}.'.'.$priv.'.roles.denied'}
1.194 www 1558: =~/$rolecode/) {
1.57 www 1559: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
1560: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode.' in '.
1.54 www 1561: $ENV{'request.course.id'});
1562: return '';
1563: }
1.53 www 1564: }
1565:
1566: # Resource preferences
1567:
1568: if ($thisallowed=~/R/) {
1.54 www 1569: my $rolecode=(split(/\./,$ENV{'request.role'}))[0];
1570: my $filename=$perlvar{'lonDocRoot'}.'/res/'.$uri.'.meta';
1571: if (-e $filename) {
1572: my @content;
1573: {
1574: my $fh=Apache::File->new($filename);
1575: @content=<$fh>;
1576: }
1577: if (join('',@content)=~
1578: /\<roledeny[^\>]*\>[^\<]*$rolecode[^\<]*\<\/roledeny\>/) {
1.57 www 1579: &log($ENV{'user.domain'},$ENV{'user.name'},$ENV{'user.host'},
1580: 'Denied by role: '.$priv.' for '.$uri.' as '.$rolecode);
1.54 www 1581: return '';
1582:
1583: }
1584: }
1.53 www 1585: }
1.30 www 1586:
1.52 www 1587: # Restricted by state?
1.30 www 1588:
1.52 www 1589: if ($thisallowed=~/X/) {
1590: if (&condval($statecond)) {
1591: return '2';
1592: } else {
1593: return '';
1594: }
1595: }
1.30 www 1596:
1.52 www 1597: return 'F';
1.12 www 1598: }
1599:
1600: # ----------------------------------------------------------------- Define Role
1601:
1602: sub definerole {
1603: if (allowed('mcr','/')) {
1604: my ($rolename,$sysrole,$domrole,$courole)=@_;
1.191 harris41 1605: foreach (split('/',$sysrole)) {
1.21 www 1606: my ($crole,$cqual)=split(/\&/,$_);
1607: if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
1608: if ($pr{'cr:s'}=~/$crole\&/) {
1609: if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) {
1610: return "refused:s:$crole&$cqual";
1611: }
1612: }
1.191 harris41 1613: }
1614: foreach (split('/',$domrole)) {
1.21 www 1615: my ($crole,$cqual)=split(/\&/,$_);
1616: if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
1617: if ($pr{'cr:d'}=~/$crole\&/) {
1618: if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) {
1619: return "refused:d:$crole&$cqual";
1620: }
1621: }
1.191 harris41 1622: }
1623: foreach (split('/',$courole)) {
1.21 www 1624: my ($crole,$cqual)=split(/\&/,$_);
1625: if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
1626: if ($pr{'cr:c'}=~/$crole\&/) {
1627: if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) {
1628: return "refused:c:$crole&$cqual";
1629: }
1630: }
1.191 harris41 1631: }
1.12 www 1632: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
1633: "$ENV{'user.domain'}:$ENV{'user.name'}:".
1.21 www 1634: "rolesdef_$rolename=".
1635: escape($sysrole.'_'.$domrole.'_'.$courole);
1.12 www 1636: return reply($command,$ENV{'user.home'});
1637: } else {
1638: return 'refused';
1639: }
1.105 harris41 1640: }
1641:
1642: # ---------------- Make a metadata query against the network of library servers
1643:
1644: sub metadata_query {
1.116 harris41 1645: my ($query,$custom,$customshow)=@_;
1.120 harris41 1646: my %rhash;
1.123 harris41 1647: for my $server (keys %libserv) {
1.118 harris41 1648: unless ($custom or $customshow) {
1649: my $reply=&reply("querysend:".&escape($query),$server);
1650: $rhash{$server}=$reply;
1651: }
1652: else {
1653: my $reply=&reply("querysend:".&escape($query).':'.
1654: &escape($custom).':'.&escape($customshow),
1655: $server);
1656: $rhash{$server}=$reply;
1657: }
1.112 harris41 1658: }
1.118 harris41 1659: return \%rhash;
1.12 www 1660: }
1661:
1662: # ------------------------------------------------------------------ Plain Text
1663:
1664: sub plaintext {
1.22 www 1665: my $short=shift;
1666: return $prp{$short};
1.12 www 1667: }
1668:
1669: # ----------------------------------------------------------------- Assign Role
1670:
1671: sub assignrole {
1.21 www 1672: my ($udom,$uname,$url,$role,$end,$start)=@_;
1673: my $mrole;
1674: if ($role =~ /^cr\//) {
1.104 www 1675: unless (&allowed('ccr',$url)) {
1676: &logthis('Refused custom assignrole: '.
1677: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
1678: $ENV{'user.name'}.' at '.$ENV{'user.domain'});
1679: return 'refused';
1680: }
1.21 www 1681: $mrole='cr';
1682: } else {
1.82 www 1683: my $cwosec=$url;
1.83 www 1684: $cwosec=~s/^\/(\w+)\/(\w+)\/.*/$1\/$2/;
1.104 www 1685: unless (&allowed('c'.$role,$cwosec)) {
1686: &logthis('Refused assignrole: '.
1687: $udom.' '.$uname.' '.$url.' '.$role.' '.$end.' '.$start.' by '.
1688: $ENV{'user.name'}.' at '.$ENV{'user.domain'});
1689: return 'refused';
1690: }
1.21 www 1691: $mrole=$role;
1692: }
1693: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
1694: "$udom:$uname:$url".'_'."$mrole=$role";
1.81 www 1695: if ($end) { $command.='_'.$end; }
1.21 www 1696: if ($start) {
1697: if ($end) {
1.81 www 1698: $command.='_'.$start;
1.21 www 1699: } else {
1.81 www 1700: $command.='_0_'.$start;
1.21 www 1701: }
1702: }
1703: return &reply($command,&homeserver($uname,$udom));
1.169 harris41 1704: }
1705:
1706: # -------------------------------------------------- Modify user authentication
1707: sub modifyuserauth {
1708: my ($udom,$uname,$umode,$upass)=@_;
1709: my $uhome=&homeserver($uname,$udom);
1710: &logthis('Call to modify user authentication'.$udom.', '.$uname.', '.
1711: $umode.' by '.$ENV{'user.name'}.' at '.$ENV{'user.domain'});
1712: my $reply=&reply('encrypt:changeuserauth:'.$udom.':'.$uname.':'.$umode.':'.
1713: &escape($upass),$uhome);
1714: unless ($reply eq 'ok') {
1715: return 'error: '.$reply;
1716: }
1.170 harris41 1717: return 'ok';
1.80 www 1718: }
1719:
1.81 www 1720: # --------------------------------------------------------------- Modify a user
1.80 www 1721:
1722:
1.81 www 1723: sub modifyuser {
1.80 www 1724: my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene)=@_;
1.81 www 1725: &logthis('Call to modify user '.$udom.', '.$uname.', '.$uid.', '.
1.80 www 1726: $umode.', '.$first.', '.$middle.', '.
1727: $last.', '.$gene.' by '.
1728: $ENV{'user.name'}.' at '.$ENV{'user.domain'});
1729: my $uhome=&homeserver($uname,$udom);
1730: # ----------------------------------------------------------------- Create User
1.81 www 1731: if (($uhome eq 'no_host') && ($umode) && ($upass)) {
1.80 www 1732: my $unhome='';
1733: if ($ENV{'course.'.$ENV{'request.course.id'}.'.domain'} eq $udom) {
1734: $unhome=$ENV{'course.'.$ENV{'request.course.id'}.'.home'};
1735: } else {
1736: my $tryserver;
1.81 www 1737: my $loadm=10000000;
1.80 www 1738: foreach $tryserver (keys %libserv) {
1739: if ($hostdom{$tryserver} eq $udom) {
1740: my $answer=reply('load',$tryserver);
1741: if (($answer=~/\d+/) && ($answer<$loadm)) {
1742: $loadm=$answer;
1743: $unhome=$tryserver;
1744: }
1745: }
1746: }
1747: }
1748: if (($unhome eq '') || ($unhome eq 'no_host')) {
1749: return 'error: find home';
1750: }
1751: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':'.$umode.':'.
1752: &escape($upass),$unhome);
1753: unless ($reply eq 'ok') {
1754: return 'error: '.$reply;
1755: }
1756: $uhome=&homeserver($uname,$udom);
1757: if (($uhome eq '') || ($uhome eq 'no_host') || ($uhome ne $unhome)) {
1758: return 'error: verify home';
1759: }
1760: }
1761: # ---------------------------------------------------------------------- Add ID
1762: if ($uid) {
1763: $uid=~tr/A-Z/a-z/;
1764: my %uidhash=&idrget($udom,$uname);
1765: if (($uidhash{$uname}) && ($uidhash{$uname}!~/error\:/)) {
1766: unless ($uid eq $uidhash{$uname}) {
1767: return 'error: mismatch '.$uidhash{$uname}.' versus '.$uid;
1768: }
1769: } else {
1770: &idput($udom,($uname => $uid));
1771: }
1772: }
1773: # -------------------------------------------------------------- Add names, etc
1.134 albertel 1774: my %names=&get('environment',
1775: ['firstname','middlename','lastname','generation'],
1776: $udom,$uname);
1777: if ($first) { $names{'firstname'} = $first; }
1778: if ($middle) { $names{'middlename'} = $middle; }
1779: if ($last) { $names{'lastname'} = $last; }
1780: if ($gene) { $names{'generation'} = $gene; }
1781: my $reply = &put('environment', \%names, $udom,$uname);
1782: if ($reply ne 'ok') { return 'error: '.$reply; }
1.81 www 1783: &logthis('Success modifying user '.$udom.', '.$uname.', '.$uid.', '.
1.80 www 1784: $umode.', '.$first.', '.$middle.', '.
1785: $last.', '.$gene.' by '.
1786: $ENV{'user.name'}.' at '.$ENV{'user.domain'});
1.134 albertel 1787: return 'ok';
1.80 www 1788: }
1789:
1.81 www 1790: # -------------------------------------------------------------- Modify student
1.80 www 1791:
1.81 www 1792: sub modifystudent {
1793: my ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
1794: $end,$start)=@_;
1795: my $cid='';
1796: unless ($cid=$ENV{'request.course.id'}) {
1.80 www 1797: return 'not_in_class';
1798: }
1799: # --------------------------------------------------------------- Make the user
1.81 www 1800: my $reply=&modifyuser
1.80 www 1801: ($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene);
1802: unless ($reply eq 'ok') { return $reply; }
1.81 www 1803: my $uhome=&homeserver($uname,$udom);
1804: if (($uhome eq '') || ($uhome eq 'no_host')) {
1805: return 'error: no such user';
1806: }
1.80 www 1807: # -------------------------------------------------- Add student to course list
1.160 www 1808: $reply=critical('put:'.$ENV{'course.'.$cid.'.domain'}.':'.
1.81 www 1809: $ENV{'course.'.$cid.'.num'}.':classlist:'.
1810: &escape($uname.':'.$udom).'='.
1811: &escape($end.':'.$start),
1812: $ENV{'course.'.$cid.'.home'});
1813: unless (($reply eq 'ok') || ($reply eq 'delayed')) {
1814: return 'error: '.$reply;
1815: }
1.80 www 1816: # ---------------------------------------------------- Add student role to user
1.83 www 1817: my $uurl='/'.$cid;
1.81 www 1818: $uurl=~s/\_/\//g;
1819: if ($usec) {
1820: $uurl.='/'.$usec;
1821: }
1822: return &assignrole($udom,$uname,$uurl,'st',$end,$start);
1.21 www 1823: }
1824:
1.84 www 1825: # ------------------------------------------------- Write to course preferences
1826:
1827: sub writecoursepref {
1828: my ($courseid,%prefs)=@_;
1829: $courseid=~s/^\///;
1830: $courseid=~s/\_/\//g;
1831: my ($cdomain,$cnum)=split(/\//,$courseid);
1832: my $chome=homeserver($cnum,$cdomain);
1833: if (($chome eq '') || ($chome eq 'no_host')) {
1834: return 'error: no such course';
1835: }
1836: my $cstring='';
1.191 harris41 1837: foreach (keys %prefs) {
1.84 www 1838: $cstring.=escape($_).'='.escape($prefs{$_}).'&';
1.191 harris41 1839: }
1.84 www 1840: $cstring=~s/\&$//;
1841: return reply('put:'.$cdomain.':'.$cnum.':environment:'.$cstring,$chome);
1842: }
1843:
1844: # ---------------------------------------------------------- Make/modify course
1845:
1846: sub createcourse {
1847: my ($udom,$description,$url)=@_;
1848: $url=&declutter($url);
1849: my $cid='';
1850: unless (&allowed('ccc',$ENV{'user.domain'})) {
1851: return 'refused';
1852: }
1853: unless ($udom eq $ENV{'user.domain'}) {
1854: return 'refused';
1855: }
1856: # ------------------------------------------------------------------- Create ID
1857: my $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
1858: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
1859: # ----------------------------------------------- Make sure that does not exist
1860: my $uhome=&homeserver($uname,$udom);
1861: unless (($uhome eq '') || ($uhome eq 'no_host')) {
1862: $uname=substr($$.time,0,5).unpack("H8",pack("I32",time)).
1863: unpack("H2",pack("I32",int(rand(255)))).$perlvar{'lonHostID'};
1864: $uhome=&homeserver($uname,$udom);
1865: unless (($uhome eq '') || ($uhome eq 'no_host')) {
1866: return 'error: unable to generate unique course-ID';
1867: }
1868: }
1869: # ------------------------------------------------------------- Make the course
1870: my $reply=&reply('encrypt:makeuser:'.$udom.':'.$uname.':none::',
1871: $ENV{'user.home'});
1872: unless ($reply eq 'ok') { return 'error: '.$reply; }
1.160 www 1873: $uhome=&homeserver($uname,$udom);
1.84 www 1874: if (($uhome eq '') || ($uhome eq 'no_host')) {
1875: return 'error: no such course';
1876: }
1877: &writecoursepref($udom.'_'.$uname,
1878: ('description' => $description,
1879: 'url' => $url));
1880: return '/'.$udom.'/'.$uname;
1881: }
1882:
1.21 www 1883: # ---------------------------------------------------------- Assign Custom Role
1884:
1885: sub assigncustomrole {
1886: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;
1887: return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
1888: $end,$start);
1889: }
1890:
1891: # ----------------------------------------------------------------- Revoke Role
1892:
1893: sub revokerole {
1894: my ($udom,$uname,$url,$role)=@_;
1895: my $now=time;
1896: return &assignrole($udom,$uname,$url,$role,$now);
1897: }
1898:
1899: # ---------------------------------------------------------- Revoke Custom Role
1900:
1901: sub revokecustomrole {
1902: my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;
1903: my $now=time;
1904: return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);
1.17 www 1905: }
1906:
1907: # ------------------------------------------------------------ Directory lister
1908:
1909: sub dirlist {
1910: my $uri=shift;
1.18 www 1911: $uri=~s/^\///;
1912: $uri=~s/\/$//;
1.19 www 1913: my ($res,$udom,$uname,@rest)=split(/\//,$uri);
1914: if ($udom) {
1915: if ($uname) {
1916: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri,
1917: homeserver($uname,$udom));
1918: return split(/:/,$listing);
1919: } else {
1920: my $tryserver;
1921: my %allusers=();
1922: foreach $tryserver (keys %libserv) {
1923: if ($hostdom{$tryserver} eq $udom) {
1924: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom,
1925: $tryserver);
1926: if (($listing ne 'no_such_dir') && ($listing ne 'empty')
1927: && ($listing ne 'con_lost')) {
1.191 harris41 1928: foreach (split(/:/,$listing)) {
1.19 www 1929: my ($entry,@stat)=split(/&/,$_);
1930: $allusers{$entry}=1;
1.191 harris41 1931: }
1.19 www 1932: }
1933: }
1934: }
1935: my $alluserstr='';
1.191 harris41 1936: foreach (sort keys %allusers) {
1.19 www 1937: $alluserstr.=$_.'&user:';
1.191 harris41 1938: }
1.19 www 1939: $alluserstr=~s/:$//;
1940: return split(/:/,$alluserstr);
1941: }
1942: } else {
1943: my $tryserver;
1944: my %alldom=();
1945: foreach $tryserver (keys %libserv) {
1946: $alldom{$hostdom{$tryserver}}=1;
1947: }
1948: my $alldomstr='';
1.191 harris41 1949: foreach (sort keys %alldom) {
1.19 www 1950: $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
1.191 harris41 1951: }
1.19 www 1952: $alldomstr=~s/:$//;
1953: return split(/:/,$alldomstr);
1954: }
1.26 www 1955: }
1956:
1957: # -------------------------------------------------------- Value of a Condition
1958:
1.40 www 1959: sub directcondval {
1960: my $number=shift;
1961: if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
1962: return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
1963: } else {
1964: return 2;
1965: }
1966: }
1967:
1.26 www 1968: sub condval {
1969: my $condidx=shift;
1970: my $result=0;
1.54 www 1971: my $allpathcond='';
1.191 harris41 1972: foreach (split(/\|/,$condidx)) {
1.54 www 1973: if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_})) {
1974: $allpathcond.=
1975: '('.$ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$_}.')|';
1976: }
1.191 harris41 1977: }
1.54 www 1978: $allpathcond=~s/\|$//;
1.33 www 1979: if ($ENV{'request.course.id'}) {
1.54 www 1980: if ($allpathcond) {
1.26 www 1981: my $operand='|';
1982: my @stack;
1.191 harris41 1983: foreach ($allpathcond=~/(\d+|\(|\)|\&|\|)/g) {
1.26 www 1984: if ($_ eq '(') {
1985: push @stack,($operand,$result)
1986: } elsif ($_ eq ')') {
1987: my $before=pop @stack;
1988: if (pop @stack eq '&') {
1989: $result=$result>$before?$before:$result;
1990: } else {
1991: $result=$result>$before?$result:$before;
1992: }
1993: } elsif (($_ eq '&') || ($_ eq '|')) {
1994: $operand=$_;
1995: } else {
1.40 www 1996: my $new=directcondval($_);
1.26 www 1997: if ($operand eq '&') {
1998: $result=$result>$new?$new:$result;
1999: } else {
2000: $result=$result>$new?$result:$new;
1.191 harris41 2001: }
1.26 www 2002: }
1.191 harris41 2003: }
1.26 www 2004: }
2005: }
2006: return $result;
1.28 www 2007: }
2008:
2009: # --------------------------------------------------------- Value of a Variable
2010:
1.58 www 2011: sub EXT {
1.147 www 2012: my ($varname,$symbparm)=@_;
1.68 www 2013: unless ($varname) { return ''; }
1.48 www 2014: my ($realm,$space,$qualifier,@therest)=split(/\./,$varname);
2015: my $rest;
2016: if ($therest[0]) {
2017: $rest=join('.',@therest);
2018: } else {
2019: $rest='';
2020: }
1.57 www 2021: my $qualifierrest=$qualifier;
2022: if ($rest) { $qualifierrest.='.'.$rest; }
2023: my $spacequalifierrest=$space;
2024: if ($qualifierrest) { $spacequalifierrest.='.'.$qualifierrest; }
1.28 www 2025: if ($realm eq 'user') {
1.48 www 2026: # --------------------------------------------------------------- user.resource
2027: if ($space eq 'resource') {
1.122 albertel 2028: my %restored=&restore();
1.57 www 2029: return $restored{$qualifierrest};
1.48 www 2030: # ----------------------------------------------------------------- user.access
2031: } elsif ($space eq 'access') {
2032: return &allowed($qualifier,$rest);
2033: # ------------------------------------------ user.preferences, user.environment
2034: } elsif (($space eq 'preferences') || ($space eq 'environment')) {
1.57 www 2035: return $ENV{join('.',('environment',$qualifierrest))};
1.48 www 2036: # ----------------------------------------------------------------- user.course
2037: } elsif ($space eq 'course') {
2038: return $ENV{join('.',('request.course',$qualifier))};
2039: # ------------------------------------------------------------------- user.role
2040: } elsif ($space eq 'role') {
2041: my ($role,$where)=split(/\./,$ENV{'request.role'});
2042: if ($qualifier eq 'value') {
2043: return $role;
2044: } elsif ($qualifier eq 'extent') {
2045: return $where;
2046: }
2047: # ----------------------------------------------------------------- user.domain
2048: } elsif ($space eq 'domain') {
2049: return $ENV{'user.domain'};
2050: # ------------------------------------------------------------------- user.name
2051: } elsif ($space eq 'name') {
2052: return $ENV{'user.name'};
2053: # ---------------------------------------------------- Any other user namespace
1.29 www 2054: } else {
1.48 www 2055: my $item=($rest)?$qualifier.'.'.$rest:$qualifier;
1.131 albertel 2056: my %reply=&get($space,[$item]);
1.48 www 2057: return $reply{$item};
2058: }
2059: } elsif ($realm eq 'request') {
2060: # ------------------------------------------------------------- request.browser
2061: if ($space eq 'browser') {
2062: return $ENV{'browser.'.$qualifier};
1.57 www 2063: # ------------------------------------------------------------ request.filename
2064: } else {
2065: return $ENV{'request.'.$spacequalifierrest};
1.29 www 2066: }
1.28 www 2067: } elsif ($realm eq 'course') {
1.48 www 2068: # ---------------------------------------------------------- course.description
1.127 ng 2069: return $ENV{'course.'.$ENV{'request.course.id'}.'.'.
1.57 www 2070: $spacequalifierrest};
2071: } elsif ($realm eq 'resource') {
1.127 ng 2072: if ($ENV{'request.course.id'}) {
1.165 www 2073:
2074: # print '<br>'.$space.' - '.$qualifier.' - '.$spacequalifierrest;
2075:
2076:
1.60 www 2077: # ----------------------------------------------------- Cascading lookup scheme
1.147 www 2078: my $symbp;
2079: if ($symbparm) {
2080: $symbp=$symbparm;
2081: } else {
2082: $symbp=&symbread();
2083: }
1.127 ng 2084: my $mapp=(split(/\_\_\_/,$symbp))[0];
1.69 www 2085:
1.127 ng 2086: my $symbparm=$symbp.'.'.$spacequalifierrest;
2087: my $mapparm=$mapp.'___(all).'.$spacequalifierrest;
1.69 www 2088:
1.127 ng 2089: my $seclevel=
1.69 www 2090: $ENV{'request.course.id'}.'.['.
2091: $ENV{'request.course.sec'}.'].'.$spacequalifierrest;
1.127 ng 2092: my $seclevelr=
1.69 www 2093: $ENV{'request.course.id'}.'.['.
2094: $ENV{'request.course.sec'}.'].'.$symbparm;
1.127 ng 2095: my $seclevelm=
1.69 www 2096: $ENV{'request.course.id'}.'.['.
2097: $ENV{'request.course.sec'}.'].'.$mapparm;
2098:
1.127 ng 2099: my $courselevel=
1.60 www 2100: $ENV{'request.course.id'}.'.'.$spacequalifierrest;
1.127 ng 2101: my $courselevelr=
1.69 www 2102: $ENV{'request.course.id'}.'.'.$symbparm;
1.127 ng 2103: my $courselevelm=
1.69 www 2104: $ENV{'request.course.id'}.'.'.$mapparm;
2105:
1.60 www 2106: # ----------------------------------------------------------- first, check user
1.127 ng 2107: my %resourcedata=get('resourcedata',
1.131 albertel 2108: [$courselevelr,$courselevelm,$courselevel]);
1.127 ng 2109: if (($resourcedata{$courselevelr}!~/^error\:/) &&
2110: ($resourcedata{$courselevelr}!~/^con_lost/)) {
1.69 www 2111:
1.127 ng 2112: if ($resourcedata{$courselevelr}) {
2113: return $resourcedata{$courselevelr}; }
2114: if ($resourcedata{$courselevelm}) {
2115: return $resourcedata{$courselevelm}; }
2116: if ($resourcedata{$courselevel}) { return $resourcedata{$courselevel}; }
1.69 www 2117:
1.94 www 2118: } else {
2119: if ($resourcedata{$courselevelr}!~/No such file/) {
2120: &logthis("<font color=blue>WARNING:".
2121: " Trying to get resource data for ".$ENV{'user.name'}." at "
2122: .$ENV{'user.domain'}.": ".$resourcedata{$courselevelr}.
2123: "</font>");
2124: }
1.63 www 2125: }
1.95 www 2126:
1.60 www 2127: # -------------------------------------------------------- second, check course
1.96 www 2128:
1.60 www 2129: my $reply=&reply('get:'.
1.96 www 2130: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.':'.
2131: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
1.79 www 2132: ':resourcedata:'.
2133: &escape($seclevelr).'&'.&escape($seclevelm).'&'.&escape($seclevel).'&'.
2134: &escape($courselevelr).'&'.&escape($courselevelm).'&'.&escape($courselevel),
1.96 www 2135: $ENV{'course.'.$ENV{'request.course.id'}.'.home'});
1.63 www 2136: if ($reply!~/^error\:/) {
1.191 harris41 2137: foreach (split(/\&/,$reply)) {
1.79 www 2138: if ($_) { return &unescape($_); }
1.191 harris41 2139: }
1.63 www 2140: }
1.94 www 2141: if (($reply=~/^con_lost/) || ($reply=~/^error\:/)) {
2142: &logthis("<font color=blue>WARNING:".
1.95 www 2143: " Getting ".$reply." asking for ".$varname." for ".
1.96 www 2144: $ENV{'course.'.$ENV{'request.course.id'}.'.num'}.
1.95 www 2145: ' at '.
1.96 www 2146: $ENV{'course.'.$ENV{'request.course.id'}.'.domain'}.
1.95 www 2147: ' from '.
1.96 www 2148: $ENV{'course.'.$ENV{'request.course.id'}.'.home'}.
1.94 www 2149: "</font>");
2150: }
1.60 www 2151: # ------------------------------------------------------ third, check map parms
1.65 www 2152: my %parmhash=();
2153: my $thisparm='';
2154: if (tie(%parmhash,'GDBM_File',
2155: $ENV{'request.course.fn'}.'_parms.db',&GDBM_READER,0640)) {
2156: $thisparm=$parmhash{$symbparm};
2157: untie(%parmhash);
1.60 www 2158: }
1.65 www 2159: if ($thisparm) { return $thisparm; }
1.60 www 2160: }
2161:
2162: # --------------------------------------------- last, look in resource metadata
1.71 www 2163:
1.78 www 2164: $spacequalifierrest=~s/\./\_/;
1.71 www 2165: my $metadata=&metadata($ENV{'request.filename'},$spacequalifierrest);
2166: if ($metadata) { return $metadata; }
1.78 www 2167: $metadata=&metadata($ENV{'request.filename'},
2168: 'parameter_'.$spacequalifierrest);
2169: if ($metadata) { return $metadata; }
1.142 www 2170:
1.145 www 2171: # ------------------------------------------------------------------ Cascade up
2172:
2173: unless ($space eq '0') {
1.165 www 2174: my ($part,$id)=split(/\_/,$space);
1.145 www 2175: if ($id) {
1.147 www 2176: my $partgeneral=&EXT('resource.'.$part.'.'.$qualifierrest,
2177: $symbparm);
1.145 www 2178: if ($partgeneral) { return $partgeneral; }
2179: } else {
1.147 www 2180: my $resourcegeneral=&EXT('resource.0.'.$qualifierrest,
2181: $symbparm);
1.145 www 2182: if ($resourcegeneral) { return $resourcegeneral; }
2183: }
2184: }
1.71 www 2185:
1.48 www 2186: # ---------------------------------------------------- Any other user namespace
2187: } elsif ($realm eq 'environment') {
2188: # ----------------------------------------------------------------- environment
1.127 ng 2189: return $ENV{'environment.'.$spacequalifierrest};
1.28 www 2190: } elsif ($realm eq 'system') {
1.48 www 2191: # ----------------------------------------------------------------- system.time
2192: if ($space eq 'time') {
2193: return time;
2194: }
1.28 www 2195: }
1.48 www 2196: return '';
1.61 www 2197: }
2198:
1.71 www 2199: # ---------------------------------------------------------------- Get metadata
2200:
2201: sub metadata {
1.176 www 2202: my ($uri,$what,$liburi,$prefix,$depthcount)=@_;
1.78 www 2203:
1.71 www 2204: $uri=&declutter($uri);
1.73 www 2205: my $filename=$uri;
2206: $uri=~s/\.meta$//;
1.172 www 2207: #
2208: # Is the metadata already cached?
1.177 www 2209: # Look at timestamp of caching
1.172 www 2210: # Everything is cached by the main uri, libraries are never directly cached
2211: #
1.174 www 2212: unless (abs($metacache{$uri.':cachedtimestamp'}-time)<600) {
1.172 www 2213: #
2214: # Is this a recursive call for a library?
2215: #
1.171 www 2216: if ($liburi) {
2217: $liburi=&declutter($liburi);
2218: $filename=$liburi;
2219: }
1.140 www 2220: my %metathesekeys=();
1.73 www 2221: unless ($filename=~/\.meta$/) { $filename.='.meta'; }
2222: my $metastring=&getfile($perlvar{'lonDocRoot'}.'/res/'.$filename);
1.71 www 2223: my $parser=HTML::TokeParser->new(\$metastring);
2224: my $token;
1.140 www 2225: undef %metathesekeys;
1.71 www 2226: while ($token=$parser->get_token) {
2227: if ($token->[0] eq 'S') {
1.135 www 2228: if (defined($token->[2]->{'package'})) {
1.172 www 2229: #
2230: # This is a package - get package info
2231: #
1.136 www 2232: my $package=$token->[2]->{'package'};
2233: my $keyroot='';
1.172 www 2234: if ($prefix) {
2235: $keyroot.='_'.$prefix;
2236: } else {
2237: if (defined($token->[2]->{'part'})) {
2238: $keyroot.='_'.$token->[2]->{'part'};
2239: }
1.136 www 2240: }
2241: if (defined($token->[2]->{'id'})) {
1.165 www 2242: $keyroot.='_'.$token->[2]->{'id'};
1.136 www 2243: }
2244: if ($metacache{$uri.':packages'}) {
2245: $metacache{$uri.':packages'}.=','.$package.$keyroot;
2246: } else {
2247: $metacache{$uri.':packages'}=$package.$keyroot;
2248: }
1.191 harris41 2249: foreach (keys %packagetab) {
1.137 www 2250: if ($_=~/^$package\&/) {
2251: my ($pack,$name,$subp)=split(/\&/,$_);
1.139 www 2252: my $value=$packagetab{$_};
1.144 www 2253: my $part=$keyroot;
2254: $part=~s/^\_//;
1.139 www 2255: if ($subp eq 'display') {
2256: $value.=' [Part: '.$part.']';
2257: }
2258: my $unikey='parameter'.$keyroot.'_'.$name;
1.140 www 2259: $metathesekeys{$unikey}=1;
1.144 www 2260: $metacache{$uri.':'.$unikey.'.part'}=$part;
1.141 www 2261: unless
2262: (defined($metacache{$uri.':'.$unikey.'.'.$subp})) {
2263: $metacache{$uri.':'.$unikey.'.'.$subp}=$value;
2264: }
1.137 www 2265: }
1.191 harris41 2266: }
1.135 www 2267: } else {
1.172 www 2268: #
2269: # This is not a package - some other kind of start tag
2270: #
1.175 www 2271: my $entry=$token->[1];
1.176 www 2272: my $unikey;
2273: if ($entry eq 'import') {
2274: $unikey='';
2275: } else {
2276: $unikey=$entry;
2277: }
1.172 www 2278: if ($prefix) {
1.176 www 2279: $unikey.=$prefix;
1.172 www 2280: } else {
2281: if (defined($token->[2]->{'part'})) {
2282: $unikey.='_'.$token->[2]->{'part'};
2283: }
1.136 www 2284: }
2285: if (defined($token->[2]->{'id'})) {
1.165 www 2286: $unikey.='_'.$token->[2]->{'id'};
1.71 www 2287: }
1.175 www 2288:
2289: if ($entry eq 'import') {
2290: #
2291: # Importing a library here
1.176 www 2292: #
2293: if (defined($depthcount)) { $depthcount++; } else
2294: { $depthcount=0; }
2295: if ($depthcount<20) {
1.191 harris41 2296: foreach (split(/\,/,&metadata($uri,'keys',
2297: $parser->get_text('/import'),$unikey,
2298: $depthcount))) {
1.177 www 2299: $metathesekeys{$_}=1;
1.191 harris41 2300: }
1.176 www 2301: }
1.175 www 2302: } else {
2303:
1.72 www 2304: if (defined($token->[2]->{'name'})) {
1.71 www 2305: $unikey.='_'.$token->[2]->{'name'};
2306: }
1.140 www 2307: $metathesekeys{$unikey}=1;
1.191 harris41 2308: foreach (@{$token->[3]}) {
1.71 www 2309: $metacache{$uri.':'.$unikey.'.'.$_}=$token->[2]->{$_};
1.191 harris41 2310: }
1.78 www 2311: unless (
2312: $metacache{$uri.':'.$unikey}=$parser->get_text('/'.$entry)
2313: ) { $metacache{$uri.':'.$unikey}=
2314: $metacache{$uri.':'.$unikey.'.default'};
2315: }
1.172 www 2316: # end of not-a-package not-a-library import
1.175 www 2317: }
1.172 www 2318: # end of not-a-package start tag
2319: }
2320: # the next is the end of "start tag"
1.140 www 2321: }
1.71 www 2322: }
1.140 www 2323: $metacache{$uri.':keys'}=join(',',keys %metathesekeys);
1.174 www 2324: $metacache{$uri.':cachedtimestamp'}=time;
1.177 www 2325: # this is the end of "was not already recently cached
1.71 www 2326: }
2327: return $metacache{$uri.':'.$what};
2328: }
2329:
1.31 www 2330: # ------------------------------------------------- Update symbolic store links
2331:
2332: sub symblist {
2333: my ($mapname,%newhash)=@_;
2334: $mapname=declutter($mapname);
2335: my %hash;
2336: if (($ENV{'request.course.fn'}) && (%newhash)) {
2337: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
2338: &GDBM_WRCREAT,0640)) {
1.191 harris41 2339: foreach (keys %newhash) {
1.31 www 2340: $hash{declutter($_)}=$mapname.'___'.$newhash{$_};
1.191 harris41 2341: }
1.31 www 2342: if (untie(%hash)) {
2343: return 'ok';
2344: }
2345: }
2346: }
2347: return 'error';
2348: }
2349:
2350: # ------------------------------------------------------ Return symb list entry
2351:
2352: sub symbread {
1.44 www 2353: my $thisfn=shift;
2354: unless ($thisfn) {
1.179 www 2355: if ($ENV{'request.symb'}) { return $ENV{'request.symb'}; }
1.44 www 2356: $thisfn=$ENV{'request.filename'};
2357: }
2358: $thisfn=declutter($thisfn);
1.31 www 2359: my %hash;
1.37 www 2360: my %bighash;
2361: my $syval='';
1.45 www 2362: if (($ENV{'request.course.fn'}) && ($thisfn)) {
1.31 www 2363: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
2364: &GDBM_READER,0640)) {
2365: $syval=$hash{$thisfn};
1.37 www 2366: untie(%hash);
2367: }
2368: # ---------------------------------------------------------- There was an entry
2369: if ($syval) {
2370: unless ($syval=~/\_\d+$/) {
2371: unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
1.44 www 2372: &appenv('request.ambiguous' => $thisfn);
1.37 www 2373: return '';
2374: }
2375: $syval.=$1;
2376: }
2377: } else {
2378: # ------------------------------------------------------- Was not in symb table
2379: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
2380: &GDBM_READER,0640)) {
2381: # ---------------------------------------------- Get ID(s) for current resource
2382: my $ids=$bighash{'ids_/res/'.$thisfn};
1.65 www 2383: unless ($ids) {
2384: $ids=$bighash{'ids_/'.$thisfn};
2385: }
1.37 www 2386: if ($ids) {
2387: # ------------------------------------------------------------------- Has ID(s)
2388: my @possibilities=split(/\,/,$ids);
1.39 www 2389: if ($#possibilities==0) {
2390: # ----------------------------------------------- There is only one possibility
1.37 www 2391: my ($mapid,$resid)=split(/\./,$ids);
2392: $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
2393: } else {
1.39 www 2394: # ------------------------------------------ There is more than one possibility
2395: my $realpossible=0;
1.191 harris41 2396: foreach (@possibilities) {
1.39 www 2397: my $file=$bighash{'src_'.$_};
2398: if (&allowed('bre',$file)) {
2399: my ($mapid,$resid)=split(/\./,$_);
2400: if ($bighash{'map_type_'.$mapid} ne 'page') {
2401: $realpossible++;
2402: $syval=declutter($bighash{'map_id_'.$mapid}).
2403: '___'.$resid;
2404: }
2405: }
1.191 harris41 2406: }
1.39 www 2407: if ($realpossible!=1) { $syval=''; }
1.37 www 2408: }
2409: }
2410: untie(%bighash)
2411: }
1.31 www 2412: }
1.62 www 2413: if ($syval) {
2414: return $syval.'___'.$thisfn;
2415: }
1.31 www 2416: }
1.44 www 2417: &appenv('request.ambiguous' => $thisfn);
1.31 www 2418: return '';
2419: }
2420:
2421: # ---------------------------------------------------------- Return random seed
2422:
1.32 www 2423: sub numval {
2424: my $txt=shift;
2425: $txt=~tr/A-J/0-9/;
2426: $txt=~tr/a-j/0-9/;
2427: $txt=~tr/K-T/0-9/;
2428: $txt=~tr/k-t/0-9/;
2429: $txt=~tr/U-Z/0-5/;
2430: $txt=~tr/u-z/0-5/;
2431: $txt=~s/\D//g;
2432: return int($txt);
2433: }
2434:
1.31 www 2435: sub rndseed {
1.155 albertel 2436: my ($symb,$courseid,$domain,$username)=@_;
2437: if (!$symb) {
2438: unless ($symb=&symbread()) { return time; }
2439: }
2440: if (!$courseid) { $courseid=$ENV{'request.course.id'};}
2441: if (!$domain) {$domain=$ENV{'user.domain'};}
2442: if (!$username) {$username=$ENV{'user.name'};}
2443: {
1.98 albertel 2444: use integer;
2445: my $symbchck=unpack("%32C*",$symb) << 27;
1.100 albertel 2446: my $symbseed=numval($symb) << 22;
1.155 albertel 2447: my $namechck=unpack("%32C*",$username) << 17;
2448: my $nameseed=numval($username) << 12;
2449: my $domainseed=unpack("%32C*",$domain) << 7;
2450: my $courseseed=unpack("%32C*",$courseid);
1.98 albertel 2451: my $num=$symbseed+$nameseed+$domainseed+$courseseed+$namechck+$symbchck;
1.99 albertel 2452: #uncommenting these lines can break things!
2453: #&Apache::lonxml::debug("$symbseed:$nameseed;$domainseed|$courseseed;$namechck:$symbchck");
2454: #&Apache::lonxml::debug("rndseed :$num:$symb");
1.98 albertel 2455: return $num;
2456: }
1.36 albertel 2457: }
2458:
1.76 www 2459: sub ireceipt {
2460: my ($funame,$fudom,$fucourseid,$fusymb)=@_;
2461: my $cuname=unpack("%32C*",$funame);
2462: my $cudom=unpack("%32C*",$fudom);
2463: my $cucourseid=unpack("%32C*",$fucourseid);
2464: my $cusymb=unpack("%32C*",$fusymb);
1.77 www 2465: my $cunique=unpack("%32C*",$perlvar{'lonReceipt'});
1.76 www 2466: return unpack("%32C*",$perlvar{'lonHostID'}).'-'.
2467: ($cunique%$cuname+
2468: $cunique%$cudom+
2469: $cusymb%$cuname+
2470: $cusymb%$cudom+
2471: $cucourseid%$cuname+
2472: $cucourseid%$cudom);
2473: }
2474:
2475: sub receipt {
2476: return &ireceipt($ENV{'user.name'},$ENV{'user.domain'},
2477: $ENV{'request.course.id'},&symbread());
2478: }
2479:
1.36 albertel 2480: # ------------------------------------------------------------ Serves up a file
2481: # returns either the contents of the file or a -1
2482: sub getfile {
2483: my $file=shift;
1.37 www 2484: &repcopy($file);
1.36 albertel 2485: if (! -e $file ) { return -1; };
2486: my $fh=Apache::File->new($file);
2487: my $a='';
2488: while (<$fh>) { $a .=$_; }
2489: return $a
2490: }
2491:
2492: sub filelocation {
2493: my ($dir,$file) = @_;
2494: my $location;
2495: $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
1.59 albertel 2496: if ($file=~m:^/~:) { # is a contruction space reference
2497: $location = $file;
2498: $location =~ s:/~(.*?)/(.*):/home/$1/public_html/$2:;
1.36 albertel 2499: } else {
1.59 albertel 2500: $file=~s/^$perlvar{'lonDocRoot'}//;
2501: $file=~s:^/*res::;
2502: if ( !( $file =~ m:^/:) ) {
2503: $location = $dir. '/'.$file;
2504: } else {
2505: $location = '/home/httpd/html/res'.$file;
2506: }
1.36 albertel 2507: }
2508: $location=~s://+:/:g; # remove duplicate /
1.46 www 2509: while ($location=~m:/\.\./:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
2510: return $location;
2511: }
1.36 albertel 2512:
1.46 www 2513: sub hreflocation {
2514: my ($dir,$file)=@_;
1.191 harris41 2515: unless (($file=~/^http:\/\//i) || ($file=~/^\//)) {
1.46 www 2516: my $finalpath=filelocation($dir,$file);
2517: $finalpath=~s/^\/home\/httpd\/html//;
2518: return $finalpath;
2519: } else {
2520: return $file;
2521: }
1.31 www 2522: }
2523:
2524: # ------------------------------------------------------------- Declutters URLs
2525:
2526: sub declutter {
2527: my $thisfn=shift;
2528: $thisfn=~s/^$perlvar{'lonDocRoot'}//;
2529: $thisfn=~s/^\///;
2530: $thisfn=~s/^res\///;
2531: return $thisfn;
1.12 www 2532: }
2533:
2534: # -------------------------------------------------------- Escape Special Chars
2535:
2536: sub escape {
2537: my $str=shift;
2538: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
2539: return $str;
2540: }
2541:
2542: # ----------------------------------------------------- Un-Escape Special Chars
2543:
2544: sub unescape {
2545: my $str=shift;
2546: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
2547: return $str;
2548: }
1.11 www 2549:
1.1 albertel 2550: # ================================================================ Main Program
2551:
1.184 www 2552: sub goodbye {
2553: &flushcourselogs();
2554: &logthis("Shutting down");
2555: }
2556:
1.179 www 2557: BEGIN {
1.1 albertel 2558: # ------------------------------------------------------------ Read access.conf
1.195 ! www 2559: unless ($readit) {
1.1 albertel 2560: {
2561: my $config=Apache::File->new("/etc/httpd/conf/access.conf");
2562:
2563: while (my $configline=<$config>) {
2564: if ($configline =~ /PerlSetVar/) {
2565: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.8 www 2566: chomp($varvalue);
1.1 albertel 2567: $perlvar{$varname}=$varvalue;
2568: }
2569: }
2570: }
2571:
2572: # ------------------------------------------------------------- Read hosts file
2573: {
2574: my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
2575:
2576: while (my $configline=<$config>) {
1.154 www 2577: chomp($configline);
1.1 albertel 2578: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
2579: $hostname{$id}=$name;
2580: $hostdom{$id}=$domain;
1.150 www 2581: $hostip{$id}=$ip;
1.1 albertel 2582: if ($role eq 'library') { $libserv{$id}=$name; }
2583: }
2584: }
2585:
2586: # ------------------------------------------------------ Read spare server file
2587: {
2588: my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
2589:
2590: while (my $configline=<$config>) {
2591: chomp($configline);
2592: if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
2593: $spareid{$configline}=1;
2594: }
2595: }
2596: }
1.11 www 2597: # ------------------------------------------------------------ Read permissions
2598: {
2599: my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
2600:
2601: while (my $configline=<$config>) {
2602: chomp($configline);
1.160 www 2603: if ($configline) {
1.11 www 2604: my ($role,$perm)=split(/ /,$configline);
2605: if ($perm ne '') { $pr{$role}=$perm; }
1.160 www 2606: }
1.11 www 2607: }
2608: }
2609:
2610: # -------------------------------------------- Read plain texts for permissions
2611: {
2612: my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
2613:
2614: while (my $configline=<$config>) {
2615: chomp($configline);
1.160 www 2616: if ($configline) {
1.11 www 2617: my ($short,$plain)=split(/:/,$configline);
2618: if ($plain ne '') { $prp{$short}=$plain; }
1.160 www 2619: }
1.135 www 2620: }
2621: }
2622:
2623: # ---------------------------------------------------------- Read package table
2624: {
2625: my $config=Apache::File->new("$perlvar{'lonTabDir'}/packages.tab");
2626:
2627: while (my $configline=<$config>) {
2628: chomp($configline);
2629: my ($short,$plain)=split(/:/,$configline);
1.143 www 2630: my ($pack,$name)=split(/\&/,$short);
2631: if ($plain ne '') {
2632: $packagetab{$pack.'&'.$name.'&name'}=$name;
2633: $packagetab{$short}=$plain;
1.25 www 2634: }
1.11 www 2635: }
2636: }
2637:
1.71 www 2638: %metacache=();
1.185 www 2639:
2640: $processmarker=$$.'_'.time.'_'.$perlvar{'lonHostID'};
1.186 www 2641: $dumpcount=0;
1.22 www 2642:
1.163 harris41 2643: &logtouch();
1.12 www 2644: &logthis('<font color=yellow>INFO: Read configuration</font>');
1.195 ! www 2645: $readit=1;
! 2646: }
1.1 albertel 2647: }
1.179 www 2648:
1.1 albertel 2649: 1;
1.191 harris41 2650: __END__
2651:
2652: =head1 NAME
2653:
2654: Apache::lonnet - TCP networking package
2655:
2656: =head1 SYNOPSIS
2657:
2658: Invoked by other LON-CAPA modules.
2659:
2660: &Apache::lonnet::SUBROUTINENAME(ARGUMENTS);
2661:
2662: =head1 INTRODUCTION
2663:
2664: This module provides subroutines which interact with the
2665: lonc/lond (TCP) network layer of LON-CAPA.
2666:
2667: This is part of the LearningOnline Network with CAPA project
2668: described at http://www.lon-capa.org.
2669:
2670: =head1 HANDLER SUBROUTINE
2671:
2672: There is no handler routine for this module.
2673:
2674: =head1 OTHER SUBROUTINES
2675:
2676: =over 4
2677:
2678: =item *
2679:
2680: logtouch() : make sure the logfile, lonnet.log, exists
2681:
2682: =item *
2683:
2684: logthis() : append message to lonnet.log
2685:
2686: =item *
2687:
2688: logperm() : append a permanent message to lonnet.perm.log
2689:
2690: =item *
2691:
2692: subreply() : non-critical communication, called by &reply
2693:
2694: =item *
2695:
2696: reply() : makes two attempts to pass message; logs refusals and rejections
2697:
2698: =item *
2699:
2700: reconlonc() : tries to reconnect lonc client processes.
2701:
2702: =item *
2703:
2704: critical() : passes a critical message to another server; if cannot get
2705: through then place message in connection buffer
2706:
2707: =item *
2708:
2709: appenv(%hash) : read in current user environment, append new environment
2710: values to make new user environment
2711:
2712: =item *
2713:
2714: delenv($varname) : read in current user environment, remove all values
2715: beginning with $varname, write new user environment (note: flock is used
2716: to prevent conflicting shared read/writes with file)
2717:
2718: =item *
2719:
2720: spareserver() : find server with least workload from spare.tab
2721:
2722: =item *
2723:
2724: queryauthenticate($uname,$udom) : try to determine user's current
2725: authentication scheme
2726:
2727: =item *
2728:
2729: authenticate($uname,$upass,$udom) : try to authenticate user from domain's lib
2730: servers (first use the current one)
2731:
2732: =item *
2733:
2734: homeserver($uname,$udom) : find the homebase for a user from domain's lib
2735: servers
2736:
2737: =item *
2738:
2739: idget($udom,@ids) : find the usernames behind a list of IDs (returns hash:
2740: id=>name,id=>name)
2741:
2742: =item *
2743:
2744: idrget($udom,@unames) : find the IDs behind a list of usernames (returns hash:
2745: name=>id,name=>id)
2746:
2747: =item *
2748:
2749: idput($udom,%ids) : store away a list of names and associated IDs
2750:
2751: =item *
2752:
2753: usection($domain,$user,$courseid) : output of section name/number or '' for
2754: "not in course" and '-1' for "no section"
2755:
2756: =item *
2757:
2758: userenvironment($domain,$user,$what) : puts out any environment parameter
2759: for a user
2760:
2761: =item *
2762:
2763: subscribe($fname) : subscribe to a resource, return URL if possible
2764:
2765: =item *
2766:
2767: repcopy($filename) : replicate file
2768:
2769: =item *
2770:
2771: ssi($url,%hash) : server side include, does a complete request cycle on url to
2772: localhost, posts hash
2773:
2774: =item *
2775:
2776: log($domain,$name,$home,$message) : write to permanent log for user; use
2777: critical subroutine
2778:
2779: =item *
2780:
2781: flushcourselogs() : flush (save) buffer logs and access logs
2782:
2783: =item *
2784:
2785: courselog($what) : save message for course in hash
2786:
2787: =item *
2788:
2789: courseacclog($what) : save message for course using &courselog(). Perform
2790: special processing for specific resource types (problems, exams, quizzes, etc).
2791:
2792: =item *
2793:
2794: countacc($url) : count the number of accesses to a given URL
2795:
2796: =item *
2797:
2798: sub checkout($symb,$tuname,$tudom,$tcrsid) : check out an item
2799:
2800: =item *
2801:
2802: sub checkin($token) : check in an item
2803:
2804: =item *
2805:
2806: sub expirespread($uname,$udom,$stype,$usymb) : set expire date for spreadsheet
2807:
2808: =item *
2809:
2810: devalidate($symb) : devalidate spreadsheets
2811:
2812: =item *
2813:
2814: hash2str(%hash) : convert a hash into a string complete with escaping and '='
2815: and '&' separators
2816:
2817: =item *
2818:
2819: str2hash($string) : convert string to hash using unescaping and splitting on
2820: '=' and '&'
2821:
2822: =item *
2823:
2824: tmpreset($symb,$namespace,$domain,$stuname) : temporary storage
2825:
2826: =item *
2827:
2828: tmprestore($symb,$namespace,$domain,$stuname) : temporary restore
2829:
2830: =item *
2831:
2832: store($storehash,$symb,$namespace,$domain,$stuname) : stores hash permanently
2833: for this url; hashref needs to be given and should be a \%hashname; the
2834: remaining args aren't required and if they aren't passed or are '' they will
2835: be derived from the ENV
2836:
2837: =item *
2838:
2839: cstore($storehash,$symb,$namespace,$domain,$stuname) : same as store but
2840: uses critical subroutine
2841:
2842: =item *
2843:
2844: restore($symb,$namespace,$domain,$stuname) : returns hash for this symb;
2845: all args are optional
2846:
2847: =item *
2848:
2849: coursedescription($courseid) : course description
2850:
2851: =item *
2852:
2853: rolesinit($domain,$username,$authhost) : get user privileges
2854:
2855: =item *
2856:
2857: get($namespace,$storearr,$udomain,$uname) : returns hash with keys from array
2858: reference filled in from namesp ($udomain and $uname are optional)
2859:
2860: =item *
2861:
2862: del($namespace,$storearr,$udomain,$uname) : deletes keys out of array from
2863: namesp ($udomain and $uname are optional)
2864:
2865: =item *
2866:
1.193 www 2867: dump($namespace,$udomain,$uname,$regexp) :
2868: dumps the complete (or key matching regexp) namespace into a hash
2869: ($udomain, $uname and $regexp are optional)
1.191 harris41 2870:
2871: =item *
2872:
2873: put($namespace,$storehash,$udomain,$uname) : stores hash in namesp
2874: ($udomain and $uname are optional)
2875:
2876: =item *
2877:
2878: cput($namespace,$storehash,$udomain,$uname) : critical put
2879: ($udomain and $uname are optional)
2880:
2881: =item *
2882:
2883: eget($namespace,$storearr,$udomain,$uname) : returns hash with keys from array
2884: reference filled in from namesp (encrypts the return communication)
2885: ($udomain and $uname are optional)
2886:
2887: =item *
2888:
2889: allowed($priv,$uri) : check for a user privilege; returns codes for allowed
2890: actions
2891: F: full access
2892: U,I,K: authentication modes (cxx only)
2893: '': forbidden
2894: 1: user needs to choose course
2895: 2: browse allowed
2896:
2897: =item *
2898:
2899: definerole($rolename,$sysrole,$domrole,$courole) : define role; define a custom
2900: role rolename set privileges in format of lonTabs/roles.tab for system, domain,
2901: and course level
2902:
2903: =item *
2904:
2905: metadata_query($query,$custom,$customshow) : make a metadata query against the
2906: network of library servers; returns file handle of where SQL and regex results
2907: will be stored for query
2908:
2909: =item *
2910:
2911: plaintext($short) : return value in %prp hash (rolesplain.tab); plain text
2912: explanation of a user role term
2913:
2914: =item *
2915:
2916: assignrole($udom,$uname,$url,$role,$end,$start) : assign role; give a role to a
2917: user for the level given by URL. Optional start and end dates (leave empty
2918: string or zero for "no date")
2919:
2920: =item *
2921:
2922: modifyuserauth($udom,$uname,$umode,$upass) : modify user authentication
2923:
2924: =item *
2925:
2926: modifyuser($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene) :
2927: modify user
2928:
2929: =item *
2930:
2931: modifystudent($udom,$uname,$uid,$umode,$upass,$first,$middle,$last,$gene,$usec,
2932: $end,$start) : modify student
2933:
2934: =item *
2935:
2936: writecoursepref($courseid,%prefs) : write preferences for a course
2937:
2938: =item *
2939:
2940: createcourse($udom,$description,$url) : make/modify course
2941:
2942: =item *
2943:
2944: assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start) : assign
2945: custom role; give a custom role to a user for the level given by URL. Specify
2946: name and domain of role author, and role name
2947:
2948: =item *
2949:
2950: revokerole($udom,$uname,$url,$role) : revoke a role for url
2951:
2952: =item *
2953:
2954: revokecustomrole($udom,$uname,$url,$role) : revoke a custom role
2955:
2956: =item *
2957:
2958: dirlist($uri) : return directory list based on URI
2959:
2960: =item *
2961:
2962: directcondval($number) : get current value of a condition; reads from a state
2963: string
2964:
2965: =item *
2966:
2967: condval($condidx) : value of condition index based on state
2968:
2969: =item *
2970:
2971: EXT($varname,$symbparm) : value of a variable
2972:
2973: =item *
2974:
2975: metadata($uri,$what,$liburi,$prefix,$depthcount) : get metadata; returns the
2976: metadata entry for a file; entry='keys', returns a comma separated list of keys
2977:
2978: =item *
2979:
2980: symblist($mapname,%newhash) : update symbolic storage links
2981:
2982: =item *
2983:
2984: symbread($filename) : return symbolic list entry (filename argument optional);
2985: returns the data handle
2986:
2987: =item *
2988:
2989: numval($salt) : return random seed value (addend for rndseed)
2990:
2991: =item *
2992:
2993: rndseed($symb,$courseid,$domain,$username) : create a random sum; returns
2994: a random seed, all arguments are optional, if they aren't sent it uses the
2995: environment to derive them. Note: if symb isn't sent and it can't get one
2996: from &symbread it will use the current time as its return value
2997:
2998: =item *
2999:
3000: ireceipt($funame,$fudom,$fucourseid,$fusymb) : return unique,
3001: unfakeable, receipt
3002:
3003: =item *
3004:
3005: receipt() : API to ireceipt working off of ENV values; given out to users
3006:
3007: =item *
3008:
3009: getfile($file) : serves up a file, returns the contents of a file or -1;
3010: replicates and subscribes to the file
3011:
3012: =item *
3013:
3014: filelocation($dir,$file) : returns file system location of a file based on URI;
3015: meant to be "fairly clean" absolute reference
3016:
3017: =item *
3018:
3019: hreflocation($dir,$file) : returns file system location or a URL; same as
3020: filelocation except for hrefs
3021:
3022: =item *
3023:
3024: declutter() : declutters URLs (remove docroot, beginning slashes, 'res' etc)
3025:
3026: =item *
3027:
3028: escape() : unpack non-word characters into CGI-compatible hex codes
3029:
3030: =item *
3031:
3032: unescape() : pack CGI-compatible hex codes into actual non-word ASCII character
3033:
3034: =item *
3035:
3036: goodbye() : flush course logs and log shutting down; it is called in srm.conf
3037: as a PerlChildExitHandler
3038:
3039: =back
3040:
3041: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonnet.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom / lonnet / perl