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