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