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