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