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