Annotation of loncom/lonnet/perl/lonnet.pm, revision 1.42
1.1 albertel 1: # The LearningOnline Network
2: # TCP networking package
1.12 www 3: #
4: # Functions for use by content handlers:
5: #
6: # plaintext(short) : plain text explanation of short term
1.25 www 7: # fileembstyle(ext) : embed style in page for file extension
8: # filedescription(ext) : descriptor text for file extension
1.29 www 9: # allowed(short,url) : returns codes for allowed actions
10: # F: full access
11: # U,I,K: authentication modes (cxx only)
12: # '': forbidden
13: # 1: user needs to choose course
14: # 2: browse allowed
1.21 www 15: # definerole(rolename,sys,dom,cou) : define a custom role rolename
16: # set priviledges in format of lonTabs/roles.tab for
17: # system, domain and course level,
18: # assignrole(udom,uname,url,role,end,start) : give a role to a user for the
19: # level given by url. Optional start and end dates
20: # (leave empty string or zero for "no date")
21: # assigncustomrole (udom,uname,url,rdom,rnam,rolename,end,start) : give a
22: # custom role to a user for the level given by url.
23: # Specify name and domain of role author, and role name
24: # revokerole (udom,uname,url,role) : Revoke a role for url
25: # revokecustomrole (udom,uname,url,rdom,rnam,rolename) : Revoke a custom role
1.24 www 26: # appenv(hash) : adds hash to session environment
1.12 www 27: # store(hash) : stores hash permanently for this url
28: # restore : returns hash for this url
29: # eget(namesp,array) : returns hash with keys from array filled in from namesp
30: # get(namesp,array) : returns hash with keys from array filled in from namesp
1.38 www 31: # del(namesp,array) : deletes keys out of array from namesp
1.12 www 32: # put(namesp,hash) : stores hash in namesp
1.15 www 33: # dump(namesp) : dumps the complete namespace into a hash
1.23 www 34: # ssi(url,hash) : does a complete request cycle on url to localhost, posts
35: # hash
1.34 www 36: # coursedescription(id) : returns and caches course description for id
1.17 www 37: # repcopy(filename) : replicate file
38: # dirlist(url) : gets a directory listing
1.40 www 39: # directcondval(index) : reading condition value of single condition from
40: # state string
1.28 www 41: # condval(index) : value of condition index based on state
1.29 www 42: # varval(name) : value of a variable
1.31 www 43: # refreshstate() : refresh the state information string
44: # symblist(map,hash) : Updates symbolic storage links
1.38 www 45: # symbread(filename) : returns the data handle
1.31 www 46: # rndseed() : returns a random seed
1.36 albertel 47: # getfile(filename) : returns the contents of filename, or a -1 if it can't
48: # be found, replicates and subscribes to the file
49: # filelocation(dir,file) : returns a farily clean absolute reference to file
50: # from the directory dir
1.12 www 51: #
1.1 albertel 52: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
1.5 www 53: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
1.8 www 54: # 11/8,11/16,11/18,11/22,11/23,12/22,
1.12 www 55: # 01/06,01/13,02/24,02/28,02/29,
56: # 03/01,03/02,03/06,03/07,03/13,
1.15 www 57: # 04/05,05/29,05/31,06/01,
58: # 06/05,06/26 Gerd Kortemeyer
59: # 06/26 Ben Tyszka
1.22 www 60: # 06/30,07/15,07/17,07/18,07/20,07/21,07/22,07/25 Gerd Kortemeyer
1.23 www 61: # 08/14 Ben Tyszka
1.36 albertel 62: # 08/22,08/28,08/31,09/01,09/02,09/04,09/05,09/25,09/28,09/30 Gerd Kortemeyer
1.35 www 63: # 10/04 Gerd Kortemeyer
1.36 albertel 64: # 10/04 Guy Albertelli
1.41 www 65: # 10/06,10/09,10/10 Gerd Kortemeyer
1.1 albertel 66:
67: package Apache::lonnet;
68:
69: use strict;
70: use Apache::File;
1.8 www 71: use LWP::UserAgent();
1.15 www 72: use HTTP::Headers;
1.11 www 73: use vars
1.25 www 74: qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp %fe %fd $readit);
1.1 albertel 75: use IO::Socket;
1.31 www 76: use GDBM_File;
1.8 www 77: use Apache::Constants qw(:common :http);
1.1 albertel 78:
79: # --------------------------------------------------------------------- Logging
80:
81: sub logthis {
82: my $message=shift;
83: my $execdir=$perlvar{'lonDaemons'};
84: my $now=time;
85: my $local=localtime($now);
86: my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
87: print $fh "$local ($$): $message\n";
88: return 1;
89: }
90:
91: sub logperm {
92: my $message=shift;
93: my $execdir=$perlvar{'lonDaemons'};
94: my $now=time;
95: my $local=localtime($now);
96: my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");
97: print $fh "$now:$message:$local\n";
98: return 1;
99: }
100:
101: # -------------------------------------------------- Non-critical communication
102: sub subreply {
103: my ($cmd,$server)=@_;
104: my $peerfile="$perlvar{'lonSockDir'}/$server";
105: my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
106: Type => SOCK_STREAM,
107: Timeout => 10)
108: or return "con_lost";
109: print $client "$cmd\n";
110: my $answer=<$client>;
1.9 www 111: if (!$answer) { $answer="con_lost"; }
1.1 albertel 112: chomp($answer);
113: return $answer;
114: }
115:
116: sub reply {
117: my ($cmd,$server)=@_;
118: my $answer=subreply($cmd,$server);
119: if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
1.12 www 120: if (($answer=~/^error:/) || ($answer=~/^refused/) ||
121: ($answer=~/^rejected/)) {
122: &logthis("<font color=blue>WARNING:".
123: " $cmd to $server returned $answer</font>");
124: }
1.1 albertel 125: return $answer;
126: }
127:
128: # ----------------------------------------------------------- Send USR1 to lonc
129:
130: sub reconlonc {
131: my $peerfile=shift;
132: &logthis("Trying to reconnect for $peerfile");
133: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
134: if (my $fh=Apache::File->new("$loncfile")) {
135: my $loncpid=<$fh>;
136: chomp($loncpid);
137: if (kill 0 => $loncpid) {
138: &logthis("lonc at pid $loncpid responding, sending USR1");
139: kill USR1 => $loncpid;
140: sleep 1;
141: if (-e "$peerfile") { return; }
142: &logthis("$peerfile still not there, give it another try");
143: sleep 5;
144: if (-e "$peerfile") { return; }
1.12 www 145: &logthis(
146: "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
1.1 albertel 147: } else {
1.12 www 148: &logthis(
149: "<font color=blue>WARNING:".
150: " lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 151: }
152: } else {
1.12 www 153: &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
1.1 albertel 154: }
155: }
156:
157: # ------------------------------------------------------ Critical communication
1.12 www 158:
1.1 albertel 159: sub critical {
160: my ($cmd,$server)=@_;
161: my $answer=reply($cmd,$server);
162: if ($answer eq 'con_lost') {
163: my $pingreply=reply('ping',$server);
164: &reconlonc("$perlvar{'lonSockDir'}/$server");
165: my $pongreply=reply('pong',$server);
166: &logthis("Ping/Pong for $server: $pingreply/$pongreply");
167: $answer=reply($cmd,$server);
168: if ($answer eq 'con_lost') {
169: my $now=time;
170: my $middlename=$cmd;
1.5 www 171: $middlename=substr($middlename,0,16);
1.1 albertel 172: $middlename=~s/\W//g;
173: my $dfilename=
174: "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";
175: {
176: my $dfh;
177: if ($dfh=Apache::File->new(">$dfilename")) {
1.7 www 178: print $dfh "$cmd\n";
1.1 albertel 179: }
180: }
181: sleep 2;
182: my $wcmd='';
183: {
184: my $dfh;
185: if ($dfh=Apache::File->new("$dfilename")) {
186: $wcmd=<$dfh>;
187: }
188: }
189: chomp($wcmd);
1.7 www 190: if ($wcmd eq $cmd) {
1.12 www 191: &logthis("<font color=blue>WARNING: ".
192: "Connection buffer $dfilename: $cmd</font>");
1.1 albertel 193: &logperm("D:$server:$cmd");
194: return 'con_delayed';
195: } else {
1.12 www 196: &logthis("<font color=red>CRITICAL:"
197: ." Critical connection failed: $server $cmd</font>");
1.1 albertel 198: &logperm("F:$server:$cmd");
199: return 'con_failed';
200: }
201: }
202: }
203: return $answer;
204: }
205:
1.5 www 206: # ---------------------------------------------------------- Append Environment
207:
208: sub appenv {
1.6 www 209: my %newenv=@_;
1.35 www 210: map {
211: if (($newenv{$_}=~/^user\.role/) || ($newenv{$_}=~/^user\.priv/)) {
212: &logthis("<font color=blue>WARNING: ".
213: "Attempt to modify environment ".$_." to ".$newenv{$_});
214: delete($newenv{$_});
215: } else {
216: $ENV{$_}=$newenv{$_};
217: }
218: } keys %newenv;
1.6 www 219: my @oldenv;
220: {
221: my $fh;
222: unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
1.5 www 223: return 'error';
1.6 www 224: }
225: @oldenv=<$fh>;
226: }
227: for (my $i=0; $i<=$#oldenv; $i++) {
228: chomp($oldenv[$i]);
1.9 www 229: if ($oldenv[$i] ne '') {
230: my ($name,$value)=split(/=/,$oldenv[$i]);
1.24 www 231: unless (defined($newenv{$name})) {
232: $newenv{$name}=$value;
233: }
1.9 www 234: }
1.6 www 235: }
236: {
237: my $fh;
238: unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
239: return 'error';
240: }
241: my $newname;
242: foreach $newname (keys %newenv) {
243: print $fh "$newname=$newenv{$newname}\n";
244: }
1.5 www 245: }
246: return 'ok';
247: }
1.1 albertel 248:
249: # ------------------------------ Find server with least workload from spare.tab
1.11 www 250:
1.1 albertel 251: sub spareserver {
252: my $tryserver;
253: my $spareserver='';
254: my $lowestserver=100;
255: foreach $tryserver (keys %spareid) {
256: my $answer=reply('load',$tryserver);
257: if (($answer =~ /\d/) && ($answer<$lowestserver)) {
258: $spareserver="http://$hostname{$tryserver}";
259: $lowestserver=$answer;
260: }
261: }
262: return $spareserver;
263: }
264:
265: # --------- Try to authenticate user from domain's lib servers (first this one)
1.11 www 266:
1.1 albertel 267: sub authenticate {
268: my ($uname,$upass,$udom)=@_;
1.12 www 269: $upass=escape($upass);
1.1 albertel 270: if (($perlvar{'lonRole'} eq 'library') &&
271: ($udom eq $perlvar{'lonDefDomain'})) {
1.3 www 272: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
1.2 www 273: if ($answer =~ /authorized/) {
1.9 www 274: if ($answer eq 'authorized') {
275: &logthis("User $uname at $udom authorized by local server");
276: return $perlvar{'lonHostID'};
277: }
278: if ($answer eq 'non_authorized') {
279: &logthis("User $uname at $udom rejected by local server");
280: return 'no_host';
281: }
1.2 www 282: }
1.1 albertel 283: }
284:
285: my $tryserver;
286: foreach $tryserver (keys %libserv) {
287: if ($hostdom{$tryserver} eq $udom) {
1.10 www 288: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
1.1 albertel 289: if ($answer =~ /authorized/) {
1.9 www 290: if ($answer eq 'authorized') {
291: &logthis("User $uname at $udom authorized by $tryserver");
292: return $tryserver;
293: }
294: if ($answer eq 'non_authorized') {
295: &logthis("User $uname at $udom rejected by $tryserver");
296: return 'no_host';
297: }
1.1 albertel 298: }
299: }
1.9 www 300: }
301: &logthis("User $uname at $udom could not be authenticated");
1.1 albertel 302: return 'no_host';
303: }
304:
305: # ---------------------- Find the homebase for a user from domain's lib servers
1.11 www 306:
1.1 albertel 307: sub homeserver {
308: my ($uname,$udom)=@_;
309:
310: my $index="$uname:$udom";
311: if ($homecache{$index}) { return "$homecache{$index}"; }
312:
313: my $tryserver;
314: foreach $tryserver (keys %libserv) {
315: if ($hostdom{$tryserver} eq $udom) {
316: my $answer=reply("home:$udom:$uname",$tryserver);
317: if ($answer eq 'found') {
318: $homecache{$index}=$tryserver;
319: return $tryserver;
320: }
321: }
322: }
323: return 'no_host';
324: }
325:
326: # ----------------------------- Subscribe to a resource, return URL if possible
1.11 www 327:
1.1 albertel 328: sub subscribe {
329: my $fname=shift;
330: my $author=$fname;
331: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
332: my ($udom,$uname)=split(/\//,$author);
333: my $home=homeserver($uname,$udom);
334: if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) {
335: return 'not_found';
336: }
337: my $answer=reply("sub:$fname",$home);
338: return $answer;
339: }
340:
1.8 www 341: # -------------------------------------------------------------- Replicate file
342:
343: sub repcopy {
344: my $filename=shift;
1.23 www 345: $filename=~s/\/+/\//g;
1.8 www 346: my $transname="$filename.in.transfer";
1.17 www 347: if ((-e $filename) || (-e $transname)) { return OK; }
1.8 www 348: my $remoteurl=subscribe($filename);
349: if ($remoteurl eq 'con_lost') {
350: &logthis("Subscribe returned con_lost: $filename");
351: return HTTP_SERVICE_UNAVAILABLE;
352: } elsif ($remoteurl eq 'not_found') {
353: &logthis("Subscribe returned not_found: $filename");
354: return HTTP_NOT_FOUND;
1.20 www 355: } elsif ($remoteurl eq 'rejected') {
356: &logthis("Subscribe returned rejected: $filename");
1.8 www 357: return FORBIDDEN;
1.20 www 358: } elsif ($remoteurl eq 'directory') {
359: return OK;
1.8 www 360: } else {
361: my @parts=split(/\//,$filename);
362: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
363: if ($path ne "$perlvar{'lonDocRoot'}/res") {
364: &logthis("Malconfiguration for replication: $filename");
365: return HTTP_BAD_REQUEST;
366: }
367: my $count;
368: for ($count=5;$count<$#parts;$count++) {
369: $path.="/$parts[$count]";
370: if ((-e $path)!=1) {
371: mkdir($path,0777);
372: }
373: }
374: my $ua=new LWP::UserAgent;
375: my $request=new HTTP::Request('GET',"$remoteurl");
376: my $response=$ua->request($request,$transname);
377: if ($response->is_error()) {
378: unlink($transname);
379: my $message=$response->status_line;
1.12 www 380: &logthis("<font color=blue>WARNING:"
381: ." LWP get: $message: $filename</font>");
1.8 www 382: return HTTP_SERVICE_UNAVAILABLE;
383: } else {
1.16 www 384: if ($remoteurl!~/\.meta$/) {
385: my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
386: my $mresponse=$ua->request($mrequest,$filename.'.meta');
387: if ($mresponse->is_error()) {
388: unlink($filename.'.meta');
389: &logthis(
390: "<font color=yellow>INFO: No metadata: $filename</font>");
391: }
392: }
1.8 www 393: rename($transname,$filename);
394: return OK;
395: }
396: }
397: }
398:
1.15 www 399: # --------------------------------------------------------- Server Side Include
400:
401: sub ssi {
402:
1.23 www 403: my ($fn,%form)=@_;
1.15 www 404:
405: my $ua=new LWP::UserAgent;
1.23 www 406:
407: my $request;
408:
409: if (%form) {
410: $request=new HTTP::Request('POST',"http://".$ENV{'HTTP_HOST'}.$fn);
411: $request->content(join '&', map { "$_=$form{$_}" } keys %form);
412: } else {
413: $request=new HTTP::Request('GET',"http://".$ENV{'HTTP_HOST'}.$fn);
414: }
415:
1.15 www 416: $request->header(Cookie => $ENV{'HTTP_COOKIE'});
417: my $response=$ua->request($request);
418:
419: return $response->content;
420: }
421:
1.14 www 422: # ------------------------------------------------------------------------- Log
423:
424: sub log {
425: my ($dom,$nam,$hom,$what)=@_;
426: return reply("log:$dom:$nam:$what",$hom);
427: }
428:
1.9 www 429: # ----------------------------------------------------------------------- Store
430:
431: sub store {
1.31 www 432: my %storehash=@_;
433: my $symb;
1.37 www 434: unless ($symb=escape(&symbread($ENV{'request.filename'}))) { return ''; }
1.31 www 435: my $namespace;
1.33 www 436: unless ($namespace=$ENV{'request.course.id'}) { return ''; }
1.12 www 437: my $namevalue='';
438: map {
439: $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
440: } keys %storehash;
441: $namevalue=~s/\&$//;
1.31 www 442: return reply(
443: "store:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb:$namevalue",
1.12 www 444: "$ENV{'user.home'}");
1.9 www 445: }
446:
447: # --------------------------------------------------------------------- Restore
448:
449: sub restore {
1.31 www 450: my $symb;
1.37 www 451: unless ($symb=escape(&symbread($ENV{'request.filename'}))) { return ''; }
1.31 www 452: my $namespace;
1.33 www 453: unless ($namespace=$ENV{'request.course.id'}) { return ''; }
1.31 www 454: my $answer=reply(
455: "restore:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$symb",
456: "$ENV{'user.home'}");
1.12 www 457: my %returnhash=();
458: map {
459: my ($name,$value)=split(/\=/,$_);
460: $returnhash{&unescape($name)}=&unescape($value);
461: } split(/\&/,$answer);
1.31 www 462: map {
463: $returnhash{$_}=$returnhash{$returnhash{'version'}.':'.$_};
464: } split(/\:/,$returnhash{$returnhash{'version'}.':keys'});
1.13 www 465: return %returnhash;
1.34 www 466: }
467:
468: # ---------------------------------------------------------- Course Description
469:
470: sub coursedescription {
471: my $courseid=shift;
472: $courseid=~s/^\///;
473: my ($cdomain,$cnum)=split(/\//,$courseid);
474: my $chome=homeserver($cnum,$cdomain);
475: if ($chome ne 'no_host') {
476: my $rep=reply("dump:$cdomain:$cnum:environment",$chome);
477: if ($rep ne 'con_lost') {
478: my %cachehash=();
479: my %returnhash=('home' => $chome,
480: 'domain' => $cdomain,
481: 'num' => $cnum);
482: map {
483: my ($name,$value)=split(/\=/,$_);
484: $name=&unescape($name);
485: $value=&unescape($value);
486: $returnhash{$name}=$value;
487: if ($name eq 'description') {
488: $cachehash{$courseid}=$value;
489: }
490: } split(/\&/,$rep);
491: $returnhash{'url'}='/res/'.declutter($returnhash{'url'});
492: $returnhash{'fn'}=$perlvar{'lonDaemons'}.'/tmp/'.
1.38 www 493: $ENV{'user.name'}.'_'.$cdomain.'_'.$cnum;
1.34 www 494: put ('coursedescriptions',%cachehash);
495: return %returnhash;
496: }
497: }
498: return ();
1.9 www 499: }
1.1 albertel 500:
1.11 www 501: # -------------------------------------------------------- Get user priviledges
502:
503: sub rolesinit {
504: my ($domain,$username,$authhost)=@_;
505: my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12 www 506: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11 www 507: my %allroles=();
508: my %thesepriv=();
509: my $now=time;
1.21 www 510: my $userroles="user.login.time=$now\n";
1.11 www 511: my $thesestr;
512:
513: if ($rolesdump ne '') {
514: map {
1.21 www 515: if ($_!~/^rolesdef\&/) {
1.11 www 516: my ($area,$role)=split(/=/,$_);
1.21 www 517: $area=~s/\_\w\w$//;
1.11 www 518: my ($trole,$tend,$tstart)=split(/_/,$role);
1.21 www 519: $userroles.='user.role.'.$trole.'.'.$area.'='.
520: $tstart.'.'.$tend."\n";
1.11 www 521: if ($tend!=0) {
522: if ($tend<$now) {
523: $trole='';
524: }
525: }
526: if ($tstart!=0) {
527: if ($tstart>$now) {
528: $trole='';
529: }
530: }
531: if (($area ne '') && ($trole ne '')) {
1.12 www 532: my ($tdummy,$tdomain,$trest)=split(/\//,$area);
533: if ($trole =~ /^cr\//) {
534: my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
535: my $homsvr=homeserver($rauthor,$rdomain);
536: if ($hostname{$homsvr} ne '') {
537: my $roledef=
1.21 www 538: reply("get:$rdomain:$rauthor:roles:rolesdef_$rrole",
1.12 www 539: $homsvr);
540: if (($roledef ne 'con_lost') && ($roledef ne '')) {
541: my ($syspriv,$dompriv,$coursepriv)=
1.21 www 542: split(/\_/,unescape($roledef));
1.12 www 543: $allroles{'/'}.=':'.$syspriv;
544: if ($tdomain ne '') {
545: $allroles{'/'.$tdomain.'/'}.=':'.$dompriv;
546: if ($trest ne '') {
547: $allroles{$area}.=':'.$coursepriv;
548: }
549: }
550: }
1.11 www 551: }
1.12 www 552: } else {
553: $allroles{'/'}.=':'.$pr{$trole.':s'};
554: if ($tdomain ne '') {
555: $allroles{'/'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
556: if ($trest ne '') {
557: $allroles{$area}.=':'.$pr{$trole.':c'};
558: }
559: }
1.11 www 560: }
1.12 www 561: }
562: }
1.11 www 563: } split(/&/,$rolesdump);
564: map {
565: %thesepriv=();
566: map {
567: if ($_ ne '') {
568: my ($priviledge,$restrictions)=split(/&/,$_);
569: if ($restrictions eq '') {
570: $thesepriv{$priviledge}='F';
571: } else {
572: if ($thesepriv{$priviledge} ne 'F') {
573: $thesepriv{$priviledge}.=$restrictions;
574: }
575: }
576: }
577: } split(/:/,$allroles{$_});
578: $thesestr='';
579: map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
580: $userroles.='user.priv.'.$_.'='.$thesestr."\n";
581: } keys %allroles;
582: }
583: return $userroles;
584: }
585:
1.12 www 586: # --------------------------------------------------------------- get interface
587:
588: sub get {
589: my ($namespace,@storearr)=@_;
590: my $items='';
591: map {
592: $items.=escape($_).'&';
593: } @storearr;
594: $items=~s/\&$//;
595: my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
596: $ENV{'user.home'});
1.15 www 597: my @pairs=split(/\&/,$rep);
598: my %returnhash=();
1.42 ! www 599: my $i=0;
1.15 www 600: map {
1.42 ! www 601: $returnhash{$_}=unescape($pairs[$i]);
! 602: $i++;
! 603: } @storearr;
1.15 www 604: return %returnhash;
1.27 www 605: }
606:
607: # --------------------------------------------------------------- del interface
608:
609: sub del {
610: my ($namespace,@storearr)=@_;
611: my $items='';
612: map {
613: $items.=escape($_).'&';
614: } @storearr;
615: $items=~s/\&$//;
616: return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
617: $ENV{'user.home'});
1.15 www 618: }
619:
620: # -------------------------------------------------------------- dump interface
621:
622: sub dump {
623: my $namespace=shift;
624: my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",
625: $ENV{'user.home'});
1.12 www 626: my @pairs=split(/\&/,$rep);
627: my %returnhash=();
628: map {
629: my ($key,$value)=split(/=/,$_);
1.29 www 630: $returnhash{unescape($key)}=unescape($value);
1.12 www 631: } @pairs;
632: return %returnhash;
633: }
634:
635: # --------------------------------------------------------------- put interface
636:
637: sub put {
638: my ($namespace,%storehash)=@_;
639: my $items='';
640: map {
641: $items.=escape($_).'='.escape($storehash{$_}).'&';
642: } keys %storehash;
643: $items=~s/\&$//;
644: return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
645: $ENV{'user.home'});
646: }
647:
648: # -------------------------------------------------------------- eget interface
649:
650: sub eget {
651: my ($namespace,@storearr)=@_;
652: my $items='';
653: map {
654: $items.=escape($_).'&';
655: } @storearr;
656: $items=~s/\&$//;
657: my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
658: $ENV{'user.home'});
659: my @pairs=split(/\&/,$rep);
660: my %returnhash=();
1.42 ! www 661: my $i=0;
1.12 www 662: map {
1.42 ! www 663: $returnhash{$_}=unescape($pairs[$i]);
! 664: $i++;
! 665: } @storearr;
1.12 www 666: return %returnhash;
667: }
668:
669: # ------------------------------------------------- Check for a user priviledge
670:
671: sub allowed {
672: my ($priv,$uri)=@_;
673: $uri=~s/^\/res//;
674: $uri=~s/^\///;
1.29 www 675:
676: # Free bre access to adm resources
677:
678: if (($uri=~/^adm\//) && ($priv eq 'bre')) {
1.14 www 679: return 'F';
680: }
1.29 www 681:
682: # Gather priviledges over system and domain
683:
1.12 www 684: my $thisallowed='';
685: if ($ENV{'user.priv./'}=~/$priv\&([^\:]*)/) {
686: $thisallowed.=$1;
687: }
688: if ($ENV{'user.priv./'.(split(/\//,$uri))[0].'/'}=~/$priv\&([^\:]*)/) {
689: $thisallowed.=$1;
690: }
1.29 www 691:
692: # Full access at system or domain level? Exit.
693:
694: if ($thisallowed=~/F/) {
695: return 'F';
696: }
697:
1.30 www 698: # The user does not have full access at system or domain level
1.29 www 699: # Course level access control
700:
701: # uri itself refering to a course?
702:
703: if ($uri=~/\.course$/) {
704: if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) {
705: $thisallowed.=$1;
706: }
1.30 www 707: # Full access on course level? Exit.
1.29 www 708: if ($thisallowed=~/F/) {
709: return 'F';
710: }
711:
712: # uri is refering to an individual resource; user needs to be in a course
713:
714: } else {
715:
1.33 www 716: unless(defined($ENV{'request.course.id'})) {
1.29 www 717: return '1';
718: }
719:
720: # Get access priviledges for course
721:
1.33 www 722: if ($ENV{'user.priv./'.$ENV{'request.course.id'}}=~/$priv\&([^\:]*)/) {
1.29 www 723: $thisallowed.=$1;
724: }
725:
726: # See if resource or referer is part of this course
727:
728: my @uriparts=split(/\//,$uri);
729: my $urifile=$uriparts[$#uriparts];
730: $urifile=~/\.(\w+)$/;
731: my $uritype=$1;
732: $#uriparts--;
733: my $uripath=join('/',@uriparts);
734: my $uricond=-1;
1.33 www 735: if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$uripath}=~
1.29 www 736: /\&$urifile\:(\d+)\&/) {
737: $uricond=$1;
738: } elsif (($fe{$uritype} eq 'emb') || ($fe{$uritype} eq 'img')) {
1.30 www 739: my $refuri=$ENV{'HTTP_REFERER'};
740: $refuri=~s/^\/res//;
741: $refuri=~s/^\///;
742: @uriparts=split(/\//,$refuri);
743: $urifile=$uriparts[$#uriparts];
744: $#uriparts--;
745: $uripath=join('/',@uriparts);
1.33 www 746: if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$uripath}=~
1.30 www 747: /\&$urifile\:(\d+)\&/) {
748: $uricond=$1;
749: }
750: }
751:
752: if ($uricond>=0) {
1.29 www 753:
1.30 www 754: # The resource is part of the course
755: # If user had full access on course level, go ahead
756:
757: if ($thisallowed=~/F/) {
758: return 'F';
759: }
760:
761: # Restricted by state?
762:
763: if ($thisallowed=~/X/) {
1.41 www 764: if (&condval($uricond)) {
1.30 www 765: return '2';
766: } else {
767: return '';
768: }
769: }
1.29 www 770: }
1.12 www 771: }
772: return $thisallowed;
773: }
774:
1.29 www 775: # ---------------------------------------------------------- Refresh State Info
776:
777: sub refreshstate {
778: }
779:
1.12 www 780: # ----------------------------------------------------------------- Define Role
781:
782: sub definerole {
783: if (allowed('mcr','/')) {
784: my ($rolename,$sysrole,$domrole,$courole)=@_;
1.21 www 785: map {
786: my ($crole,$cqual)=split(/\&/,$_);
787: if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
788: if ($pr{'cr:s'}=~/$crole\&/) {
789: if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) {
790: return "refused:s:$crole&$cqual";
791: }
792: }
793: } split('/',$sysrole);
794: map {
795: my ($crole,$cqual)=split(/\&/,$_);
796: if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
797: if ($pr{'cr:d'}=~/$crole\&/) {
798: if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) {
799: return "refused:d:$crole&$cqual";
800: }
801: }
802: } split('/',$domrole);
803: map {
804: my ($crole,$cqual)=split(/\&/,$_);
805: if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
806: if ($pr{'cr:c'}=~/$crole\&/) {
807: if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) {
808: return "refused:c:$crole&$cqual";
809: }
810: }
811: } split('/',$courole);
1.12 www 812: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
813: "$ENV{'user.domain'}:$ENV{'user.name'}:".
1.21 www 814: "rolesdef_$rolename=".
815: escape($sysrole.'_'.$domrole.'_'.$courole);
1.12 www 816: return reply($command,$ENV{'user.home'});
817: } else {
818: return 'refused';
819: }
820: }
821:
822: # ------------------------------------------------------------------ Plain Text
823:
824: sub plaintext {
1.22 www 825: my $short=shift;
826: return $prp{$short};
1.12 www 827: }
828:
1.25 www 829: # ------------------------------------------------------------------ Plain Text
830:
831: sub fileembstyle {
832: my $ending=shift;
833: return $fe{$ending};
834: }
835:
836: # ------------------------------------------------------------ Description Text
837:
838: sub filedecription {
839: my $ending=shift;
840: return $fd{$ending};
841: }
842:
1.12 www 843: # ----------------------------------------------------------------- Assign Role
844:
845: sub assignrole {
1.21 www 846: my ($udom,$uname,$url,$role,$end,$start)=@_;
847: my $mrole;
1.31 www 848: $url=declutter($url);
1.21 www 849: if ($role =~ /^cr\//) {
850: unless ($url=~/\.course$/) { return 'invalid'; }
851: unless (allowed('ccr',$url)) { return 'refused'; }
852: $mrole='cr';
853: } else {
854: unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; }
855: unless (allowed('c'+$role)) { return 'refused'; }
856: $mrole=$role;
857: }
858: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
859: "$udom:$uname:$url".'_'."$mrole=$role";
860: if ($end) { $command.='_$end'; }
861: if ($start) {
862: if ($end) {
863: $command.='_$start';
864: } else {
865: $command.='_0_$start';
866: }
867: }
868: return &reply($command,&homeserver($uname,$udom));
869: }
870:
871: # ---------------------------------------------------------- Assign Custom Role
872:
873: sub assigncustomrole {
874: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;
875: return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
876: $end,$start);
877: }
878:
879: # ----------------------------------------------------------------- Revoke Role
880:
881: sub revokerole {
882: my ($udom,$uname,$url,$role)=@_;
883: my $now=time;
884: return &assignrole($udom,$uname,$url,$role,$now);
885: }
886:
887: # ---------------------------------------------------------- Revoke Custom Role
888:
889: sub revokecustomrole {
890: my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;
891: my $now=time;
892: return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);
1.17 www 893: }
894:
895: # ------------------------------------------------------------ Directory lister
896:
897: sub dirlist {
898: my $uri=shift;
1.18 www 899: $uri=~s/^\///;
900: $uri=~s/\/$//;
1.19 www 901: my ($res,$udom,$uname,@rest)=split(/\//,$uri);
902: if ($udom) {
903: if ($uname) {
904: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri,
905: homeserver($uname,$udom));
906: return split(/:/,$listing);
907: } else {
908: my $tryserver;
909: my %allusers=();
910: foreach $tryserver (keys %libserv) {
911: if ($hostdom{$tryserver} eq $udom) {
912: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom,
913: $tryserver);
914: if (($listing ne 'no_such_dir') && ($listing ne 'empty')
915: && ($listing ne 'con_lost')) {
916: map {
917: my ($entry,@stat)=split(/&/,$_);
918: $allusers{$entry}=1;
919: } split(/:/,$listing);
920: }
921: }
922: }
923: my $alluserstr='';
924: map {
925: $alluserstr.=$_.'&user:';
926: } sort keys %allusers;
927: $alluserstr=~s/:$//;
928: return split(/:/,$alluserstr);
929: }
930: } else {
931: my $tryserver;
932: my %alldom=();
933: foreach $tryserver (keys %libserv) {
934: $alldom{$hostdom{$tryserver}}=1;
935: }
936: my $alldomstr='';
937: map {
938: $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
939: } sort keys %alldom;
940: $alldomstr=~s/:$//;
941: return split(/:/,$alldomstr);
942: }
1.26 www 943: }
944:
945: # -------------------------------------------------------- Value of a Condition
946:
1.40 www 947: sub directcondval {
948: my $number=shift;
949: if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
950: return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
951: } else {
952: return 2;
953: }
954: }
955:
1.26 www 956: sub condval {
957: my $condidx=shift;
958: my $result=0;
1.33 www 959: if ($ENV{'request.course.id'}) {
960: if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx})) {
1.26 www 961: my $operand='|';
962: my @stack;
963: map {
964: if ($_ eq '(') {
965: push @stack,($operand,$result)
966: } elsif ($_ eq ')') {
967: my $before=pop @stack;
968: if (pop @stack eq '&') {
969: $result=$result>$before?$before:$result;
970: } else {
971: $result=$result>$before?$result:$before;
972: }
973: } elsif (($_ eq '&') || ($_ eq '|')) {
974: $operand=$_;
975: } else {
1.40 www 976: my $new=directcondval($_);
1.26 www 977: if ($operand eq '&') {
978: $result=$result>$new?$new:$result;
979: } else {
980: $result=$result>$new?$result:$new;
981: }
982: }
1.33 www 983: } ($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx}=~
1.26 www 984: /(\d+|\(|\)|\&|\|)/g);
985: }
986: }
987: return $result;
1.28 www 988: }
989:
990: # --------------------------------------------------------- Value of a Variable
991:
992: sub varval {
993: my ($realm,$space,@components)=split(/\./,shift);
994: my $value='';
995: if ($realm eq 'user') {
1.29 www 996: if ($space=~/^resource/) {
997: $space=~s/^resource\[//;
998: $space=~s/\]$//;
999:
1000: } else {
1001: }
1.28 www 1002: } elsif ($realm eq 'course') {
1003: } elsif ($realm eq 'session') {
1004: } elsif ($realm eq 'system') {
1005: }
1006: return $value;
1.31 www 1007: }
1008:
1009: # ------------------------------------------------- Update symbolic store links
1010:
1011: sub symblist {
1012: my ($mapname,%newhash)=@_;
1013: $mapname=declutter($mapname);
1014: my %hash;
1015: if (($ENV{'request.course.fn'}) && (%newhash)) {
1016: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
1017: &GDBM_WRCREAT,0640)) {
1018: map {
1019: $hash{declutter($_)}=$mapname.'___'.$newhash{$_};
1020: } keys %newhash;
1021: if (untie(%hash)) {
1022: return 'ok';
1023: }
1024: }
1025: }
1026: return 'error';
1027: }
1028:
1029: # ------------------------------------------------------ Return symb list entry
1030:
1031: sub symbread {
1.37 www 1032: my $thisfn=declutter(shift);
1.31 www 1033: my %hash;
1.37 www 1034: my %bighash;
1035: my $syval='';
1.31 www 1036: if (($ENV{'request.course.fn'}) && ($ENV{'request.filename'})) {
1037: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
1038: &GDBM_READER,0640)) {
1039: $syval=$hash{$thisfn};
1.37 www 1040: untie(%hash);
1041: }
1042: # ---------------------------------------------------------- There was an entry
1043: if ($syval) {
1044: unless ($syval=~/\_\d+$/) {
1045: unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
1046: return '';
1047: }
1048: $syval.=$1;
1049: }
1050: } else {
1051: # ------------------------------------------------------- Was not in symb table
1052: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
1053: &GDBM_READER,0640)) {
1054: # ---------------------------------------------- Get ID(s) for current resource
1055: my $ids=$bighash{'ids_/res/'.$thisfn};
1056: if ($ids) {
1057: # ------------------------------------------------------------------- Has ID(s)
1058: my @possibilities=split(/\,/,$ids);
1.39 www 1059: if ($#possibilities==0) {
1060: # ----------------------------------------------- There is only one possibility
1.37 www 1061: my ($mapid,$resid)=split(/\./,$ids);
1062: $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
1063: } else {
1.39 www 1064: # ------------------------------------------ There is more than one possibility
1065: my $realpossible=0;
1066: map {
1067: my $file=$bighash{'src_'.$_};
1068: if (&allowed('bre',$file)) {
1069: my ($mapid,$resid)=split(/\./,$_);
1070: if ($bighash{'map_type_'.$mapid} ne 'page') {
1071: $realpossible++;
1072: $syval=declutter($bighash{'map_id_'.$mapid}).
1073: '___'.$resid;
1074: }
1075: }
1076: } @possibilities;
1077: if ($realpossible!=1) { $syval=''; }
1.37 www 1078: }
1079: }
1080: untie(%bighash)
1081: }
1.31 www 1082: }
1.38 www 1083: if ($syval) { return $syval.'___'.$thisfn; }
1.31 www 1084: }
1085: return '';
1086: }
1087:
1088: # ---------------------------------------------------------- Return random seed
1089:
1.32 www 1090: sub numval {
1091: my $txt=shift;
1092: $txt=~tr/A-J/0-9/;
1093: $txt=~tr/a-j/0-9/;
1094: $txt=~tr/K-T/0-9/;
1095: $txt=~tr/k-t/0-9/;
1096: $txt=~tr/U-Z/0-5/;
1097: $txt=~tr/u-z/0-5/;
1098: $txt=~s/\D//g;
1099: return int($txt);
1100: }
1101:
1.31 www 1102: sub rndseed {
1103: my $symb;
1.37 www 1104: unless ($symb=&symbread($ENV{'request.filename'})) { return ''; }
1.32 www 1105: my $symbchck=unpack("%32C*",$symb);
1106: my $symbseed=numval($symb)%$symbchck;
1107: my $namechck=unpack("%32C*",$ENV{'user.name'});
1108: my $nameseed=numval($ENV{'user.name'})%$namechck;
1109: return int( $symbseed
1110: .$nameseed
1111: .unpack("%32C*",$ENV{'user.domain'})
1.33 www 1112: .unpack("%32C*",$ENV{'request.course.id'})
1.32 www 1113: .$namechck
1114: .$symbchck);
1.36 albertel 1115: }
1116:
1117: # ------------------------------------------------------------ Serves up a file
1118: # returns either the contents of the file or a -1
1119: sub getfile {
1120: my $file=shift;
1.37 www 1121: &repcopy($file);
1.36 albertel 1122: if (! -e $file ) { return -1; };
1123: my $fh=Apache::File->new($file);
1124: my $a='';
1125: while (<$fh>) { $a .=$_; }
1126: return $a
1127: }
1128:
1129: sub filelocation {
1130: my ($dir,$file) = @_;
1131: my $location;
1132: $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
1133: $file=~s/^$perlvar{'lonDocRoot'}//;
1134: $file=~s:^/*res::;
1135: if ( !( $file =~ m:^/:) ) {
1136: $location = $dir. '/'.$file;
1137: } else {
1138: $location = '/home/httpd/html/res'.$file;
1139: }
1140: $location=~s://+:/:g; # remove duplicate /
1141: while ($location=~m:/../:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
1142:
1143: return $location;
1.31 www 1144: }
1145:
1146: # ------------------------------------------------------------- Declutters URLs
1147:
1148: sub declutter {
1149: my $thisfn=shift;
1150: $thisfn=~s/^$perlvar{'lonDocRoot'}//;
1151: $thisfn=~s/^\///;
1152: $thisfn=~s/^res\///;
1153: return $thisfn;
1.12 www 1154: }
1155:
1156: # -------------------------------------------------------- Escape Special Chars
1157:
1158: sub escape {
1159: my $str=shift;
1160: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
1161: return $str;
1162: }
1163:
1164: # ----------------------------------------------------- Un-Escape Special Chars
1165:
1166: sub unescape {
1167: my $str=shift;
1168: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1169: return $str;
1170: }
1.11 www 1171:
1.1 albertel 1172: # ================================================================ Main Program
1173:
1174: sub BEGIN {
1175: if ($readit ne 'done') {
1176: # ------------------------------------------------------------ Read access.conf
1177: {
1178: my $config=Apache::File->new("/etc/httpd/conf/access.conf");
1179:
1180: while (my $configline=<$config>) {
1181: if ($configline =~ /PerlSetVar/) {
1182: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.8 www 1183: chomp($varvalue);
1.1 albertel 1184: $perlvar{$varname}=$varvalue;
1185: }
1186: }
1187: }
1188:
1189: # ------------------------------------------------------------- Read hosts file
1190: {
1191: my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
1192:
1193: while (my $configline=<$config>) {
1194: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
1195: $hostname{$id}=$name;
1196: $hostdom{$id}=$domain;
1197: if ($role eq 'library') { $libserv{$id}=$name; }
1198: }
1199: }
1200:
1201: # ------------------------------------------------------ Read spare server file
1202: {
1203: my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
1204:
1205: while (my $configline=<$config>) {
1206: chomp($configline);
1207: if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
1208: $spareid{$configline}=1;
1209: }
1210: }
1211: }
1.11 www 1212: # ------------------------------------------------------------ Read permissions
1213: {
1214: my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
1215:
1216: while (my $configline=<$config>) {
1217: chomp($configline);
1218: my ($role,$perm)=split(/ /,$configline);
1219: if ($perm ne '') { $pr{$role}=$perm; }
1220: }
1221: }
1222:
1223: # -------------------------------------------- Read plain texts for permissions
1224: {
1225: my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
1226:
1227: while (my $configline=<$config>) {
1228: chomp($configline);
1229: my ($short,$plain)=split(/:/,$configline);
1230: if ($plain ne '') { $prp{$short}=$plain; }
1.25 www 1231: }
1232: }
1233:
1234: # ------------------------------------------------------------- Read file types
1235: {
1236: my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");
1237:
1238: while (my $configline=<$config>) {
1239: chomp($configline);
1240: my ($ending,$emb,@descr)=split(/\s+/,$configline);
1241: if ($descr[0] ne '') {
1242: $fe{$ending}=$emb;
1243: $fd{$ending}=join(' ',@descr);
1244: }
1.11 www 1245: }
1246: }
1247:
1.22 www 1248:
1.1 albertel 1249: $readit='done';
1.12 www 1250: &logthis('<font color=yellow>INFO: Read configuration</font>');
1.1 albertel 1251: }
1252: }
1253: 1;
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