Annotation of loncom/lonnet/perl/lonnet.pm, revision 1.40
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.40 ! www 65: # 10/06,10/09 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=();
599: map {
600: my ($key,$value)=split(/=/,$_);
1.29 www 601: $returnhash{unescape($key)}=unescape($value);
1.15 www 602: } @pairs;
603: return %returnhash;
1.27 www 604: }
605:
606: # --------------------------------------------------------------- del interface
607:
608: sub del {
609: my ($namespace,@storearr)=@_;
610: my $items='';
611: map {
612: $items.=escape($_).'&';
613: } @storearr;
614: $items=~s/\&$//;
615: return reply("del:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
616: $ENV{'user.home'});
1.15 www 617: }
618:
619: # -------------------------------------------------------------- dump interface
620:
621: sub dump {
622: my $namespace=shift;
623: my $rep=reply("dump:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace",
624: $ENV{'user.home'});
1.12 www 625: my @pairs=split(/\&/,$rep);
626: my %returnhash=();
627: map {
628: my ($key,$value)=split(/=/,$_);
1.29 www 629: $returnhash{unescape($key)}=unescape($value);
1.12 www 630: } @pairs;
631: return %returnhash;
632: }
633:
634: # --------------------------------------------------------------- put interface
635:
636: sub put {
637: my ($namespace,%storehash)=@_;
638: my $items='';
639: map {
640: $items.=escape($_).'='.escape($storehash{$_}).'&';
641: } keys %storehash;
642: $items=~s/\&$//;
643: return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
644: $ENV{'user.home'});
645: }
646:
647: # -------------------------------------------------------------- eget interface
648:
649: sub eget {
650: my ($namespace,@storearr)=@_;
651: my $items='';
652: map {
653: $items.=escape($_).'&';
654: } @storearr;
655: $items=~s/\&$//;
656: my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
657: $ENV{'user.home'});
658: my @pairs=split(/\&/,$rep);
659: my %returnhash=();
660: map {
661: my ($key,$value)=split(/=/,$_);
1.29 www 662: $returnhash{unescape($key)}=unescape($value);
1.12 www 663: } @pairs;
664: return %returnhash;
665: }
666:
667: # ------------------------------------------------- Check for a user priviledge
668:
669: sub allowed {
670: my ($priv,$uri)=@_;
671: $uri=~s/^\/res//;
672: $uri=~s/^\///;
1.29 www 673:
674: # Free bre access to adm resources
675:
676: if (($uri=~/^adm\//) && ($priv eq 'bre')) {
1.14 www 677: return 'F';
678: }
1.29 www 679:
680: # Gather priviledges over system and domain
681:
1.12 www 682: my $thisallowed='';
683: if ($ENV{'user.priv./'}=~/$priv\&([^\:]*)/) {
684: $thisallowed.=$1;
685: }
686: if ($ENV{'user.priv./'.(split(/\//,$uri))[0].'/'}=~/$priv\&([^\:]*)/) {
687: $thisallowed.=$1;
688: }
1.29 www 689:
690: # Full access at system or domain level? Exit.
691:
692: if ($thisallowed=~/F/) {
693: return 'F';
694: }
695:
1.30 www 696: # The user does not have full access at system or domain level
1.29 www 697: # Course level access control
698:
699: # uri itself refering to a course?
700:
701: if ($uri=~/\.course$/) {
702: if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) {
703: $thisallowed.=$1;
704: }
1.30 www 705: # Full access on course level? Exit.
1.29 www 706: if ($thisallowed=~/F/) {
707: return 'F';
708: }
709:
710: # uri is refering to an individual resource; user needs to be in a course
711:
712: } else {
713:
1.33 www 714: unless(defined($ENV{'request.course.id'})) {
1.29 www 715: return '1';
716: }
717:
718: # Get access priviledges for course
719:
1.33 www 720: if ($ENV{'user.priv./'.$ENV{'request.course.id'}}=~/$priv\&([^\:]*)/) {
1.29 www 721: $thisallowed.=$1;
722: }
723:
724: # See if resource or referer is part of this course
725:
726: my @uriparts=split(/\//,$uri);
727: my $urifile=$uriparts[$#uriparts];
728: $urifile=~/\.(\w+)$/;
729: my $uritype=$1;
730: $#uriparts--;
731: my $uripath=join('/',@uriparts);
732: my $uricond=-1;
1.33 www 733: if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$uripath}=~
1.29 www 734: /\&$urifile\:(\d+)\&/) {
735: $uricond=$1;
736: } elsif (($fe{$uritype} eq 'emb') || ($fe{$uritype} eq 'img')) {
1.30 www 737: my $refuri=$ENV{'HTTP_REFERER'};
738: $refuri=~s/^\/res//;
739: $refuri=~s/^\///;
740: @uriparts=split(/\//,$refuri);
741: $urifile=$uriparts[$#uriparts];
742: $#uriparts--;
743: $uripath=join('/',@uriparts);
1.33 www 744: if ($ENV{'acc.res.'.$ENV{'request.course.id'}.'.'.$uripath}=~
1.30 www 745: /\&$urifile\:(\d+)\&/) {
746: $uricond=$1;
747: }
748: }
749:
750: if ($uricond>=0) {
1.29 www 751:
1.30 www 752: # The resource is part of the course
753: # If user had full access on course level, go ahead
754:
755: if ($thisallowed=~/F/) {
756: return 'F';
757: }
758:
759: # Restricted by state?
760:
761: if ($thisallowed=~/X/) {
762: if (&condval($uricond)>1) {
763: return '2';
764: } else {
765: return '';
766: }
767: }
1.29 www 768: }
1.12 www 769: }
770: return $thisallowed;
771: }
772:
1.29 www 773: # ---------------------------------------------------------- Refresh State Info
774:
775: sub refreshstate {
776: }
777:
1.12 www 778: # ----------------------------------------------------------------- Define Role
779:
780: sub definerole {
781: if (allowed('mcr','/')) {
782: my ($rolename,$sysrole,$domrole,$courole)=@_;
1.21 www 783: map {
784: my ($crole,$cqual)=split(/\&/,$_);
785: if ($pr{'cr:s'}!~/$crole/) { return "refused:s:$crole"; }
786: if ($pr{'cr:s'}=~/$crole\&/) {
787: if ($pr{'cr:s'}!~/$crole\&\w*$cqual/) {
788: return "refused:s:$crole&$cqual";
789: }
790: }
791: } split('/',$sysrole);
792: map {
793: my ($crole,$cqual)=split(/\&/,$_);
794: if ($pr{'cr:d'}!~/$crole/) { return "refused:d:$crole"; }
795: if ($pr{'cr:d'}=~/$crole\&/) {
796: if ($pr{'cr:d'}!~/$crole\&\w*$cqual/) {
797: return "refused:d:$crole&$cqual";
798: }
799: }
800: } split('/',$domrole);
801: map {
802: my ($crole,$cqual)=split(/\&/,$_);
803: if ($pr{'cr:c'}!~/$crole/) { return "refused:c:$crole"; }
804: if ($pr{'cr:c'}=~/$crole\&/) {
805: if ($pr{'cr:c'}!~/$crole\&\w*$cqual/) {
806: return "refused:c:$crole&$cqual";
807: }
808: }
809: } split('/',$courole);
1.12 www 810: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
811: "$ENV{'user.domain'}:$ENV{'user.name'}:".
1.21 www 812: "rolesdef_$rolename=".
813: escape($sysrole.'_'.$domrole.'_'.$courole);
1.12 www 814: return reply($command,$ENV{'user.home'});
815: } else {
816: return 'refused';
817: }
818: }
819:
820: # ------------------------------------------------------------------ Plain Text
821:
822: sub plaintext {
1.22 www 823: my $short=shift;
824: return $prp{$short};
1.12 www 825: }
826:
1.25 www 827: # ------------------------------------------------------------------ Plain Text
828:
829: sub fileembstyle {
830: my $ending=shift;
831: return $fe{$ending};
832: }
833:
834: # ------------------------------------------------------------ Description Text
835:
836: sub filedecription {
837: my $ending=shift;
838: return $fd{$ending};
839: }
840:
1.12 www 841: # ----------------------------------------------------------------- Assign Role
842:
843: sub assignrole {
1.21 www 844: my ($udom,$uname,$url,$role,$end,$start)=@_;
845: my $mrole;
1.31 www 846: $url=declutter($url);
1.21 www 847: if ($role =~ /^cr\//) {
848: unless ($url=~/\.course$/) { return 'invalid'; }
849: unless (allowed('ccr',$url)) { return 'refused'; }
850: $mrole='cr';
851: } else {
852: unless (($url=~/\.course$/) || ($url=~/\/$/)) { return 'invalid'; }
853: unless (allowed('c'+$role)) { return 'refused'; }
854: $mrole=$role;
855: }
856: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
857: "$udom:$uname:$url".'_'."$mrole=$role";
858: if ($end) { $command.='_$end'; }
859: if ($start) {
860: if ($end) {
861: $command.='_$start';
862: } else {
863: $command.='_0_$start';
864: }
865: }
866: return &reply($command,&homeserver($uname,$udom));
867: }
868:
869: # ---------------------------------------------------------- Assign Custom Role
870:
871: sub assigncustomrole {
872: my ($udom,$uname,$url,$rdom,$rnam,$rolename,$end,$start)=@_;
873: return &assignrole($udom,$uname,$url,'cr/'.$rdom.'/'.$rnam.'/'.$rolename,
874: $end,$start);
875: }
876:
877: # ----------------------------------------------------------------- Revoke Role
878:
879: sub revokerole {
880: my ($udom,$uname,$url,$role)=@_;
881: my $now=time;
882: return &assignrole($udom,$uname,$url,$role,$now);
883: }
884:
885: # ---------------------------------------------------------- Revoke Custom Role
886:
887: sub revokecustomrole {
888: my ($udom,$uname,$url,$rdom,$rnam,$rolename)=@_;
889: my $now=time;
890: return &assigncustomrole($udom,$uname,$url,$rdom,$rnam,$rolename,$now);
1.17 www 891: }
892:
893: # ------------------------------------------------------------ Directory lister
894:
895: sub dirlist {
896: my $uri=shift;
1.18 www 897: $uri=~s/^\///;
898: $uri=~s/\/$//;
1.19 www 899: my ($res,$udom,$uname,@rest)=split(/\//,$uri);
900: if ($udom) {
901: if ($uname) {
902: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/'.$uri,
903: homeserver($uname,$udom));
904: return split(/:/,$listing);
905: } else {
906: my $tryserver;
907: my %allusers=();
908: foreach $tryserver (keys %libserv) {
909: if ($hostdom{$tryserver} eq $udom) {
910: my $listing=reply('ls:'.$perlvar{'lonDocRoot'}.'/res/'.$udom,
911: $tryserver);
912: if (($listing ne 'no_such_dir') && ($listing ne 'empty')
913: && ($listing ne 'con_lost')) {
914: map {
915: my ($entry,@stat)=split(/&/,$_);
916: $allusers{$entry}=1;
917: } split(/:/,$listing);
918: }
919: }
920: }
921: my $alluserstr='';
922: map {
923: $alluserstr.=$_.'&user:';
924: } sort keys %allusers;
925: $alluserstr=~s/:$//;
926: return split(/:/,$alluserstr);
927: }
928: } else {
929: my $tryserver;
930: my %alldom=();
931: foreach $tryserver (keys %libserv) {
932: $alldom{$hostdom{$tryserver}}=1;
933: }
934: my $alldomstr='';
935: map {
936: $alldomstr.=$perlvar{'lonDocRoot'}.'/res/'.$_.'&domain:';
937: } sort keys %alldom;
938: $alldomstr=~s/:$//;
939: return split(/:/,$alldomstr);
940: }
1.26 www 941: }
942:
943: # -------------------------------------------------------- Value of a Condition
944:
1.40 ! www 945: sub directcondval {
! 946: my $number=shift;
! 947: if ($ENV{'user.state.'.$ENV{'request.course.id'}}) {
! 948: return substr($ENV{'user.state.'.$ENV{'request.course.id'}},$number,1);
! 949: } else {
! 950: return 2;
! 951: }
! 952: }
! 953:
1.26 www 954: sub condval {
955: my $condidx=shift;
956: my $result=0;
1.33 www 957: if ($ENV{'request.course.id'}) {
958: if (defined($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx})) {
1.26 www 959: my $operand='|';
960: my @stack;
961: map {
962: if ($_ eq '(') {
963: push @stack,($operand,$result)
964: } elsif ($_ eq ')') {
965: my $before=pop @stack;
966: if (pop @stack eq '&') {
967: $result=$result>$before?$before:$result;
968: } else {
969: $result=$result>$before?$result:$before;
970: }
971: } elsif (($_ eq '&') || ($_ eq '|')) {
972: $operand=$_;
973: } else {
1.40 ! www 974: my $new=directcondval($_);
1.26 www 975: if ($operand eq '&') {
976: $result=$result>$new?$new:$result;
977: } else {
978: $result=$result>$new?$result:$new;
979: }
980: }
1.33 www 981: } ($ENV{'acc.cond.'.$ENV{'request.course.id'}.'.'.$condidx}=~
1.26 www 982: /(\d+|\(|\)|\&|\|)/g);
983: }
984: }
985: return $result;
1.28 www 986: }
987:
988: # --------------------------------------------------------- Value of a Variable
989:
990: sub varval {
991: my ($realm,$space,@components)=split(/\./,shift);
992: my $value='';
993: if ($realm eq 'user') {
1.29 www 994: if ($space=~/^resource/) {
995: $space=~s/^resource\[//;
996: $space=~s/\]$//;
997:
998: } else {
999: }
1.28 www 1000: } elsif ($realm eq 'course') {
1001: } elsif ($realm eq 'session') {
1002: } elsif ($realm eq 'system') {
1003: }
1004: return $value;
1.31 www 1005: }
1006:
1007: # ------------------------------------------------- Update symbolic store links
1008:
1009: sub symblist {
1010: my ($mapname,%newhash)=@_;
1011: $mapname=declutter($mapname);
1012: my %hash;
1013: if (($ENV{'request.course.fn'}) && (%newhash)) {
1014: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
1015: &GDBM_WRCREAT,0640)) {
1016: map {
1017: $hash{declutter($_)}=$mapname.'___'.$newhash{$_};
1018: } keys %newhash;
1019: if (untie(%hash)) {
1020: return 'ok';
1021: }
1022: }
1023: }
1024: return 'error';
1025: }
1026:
1027: # ------------------------------------------------------ Return symb list entry
1028:
1029: sub symbread {
1.37 www 1030: my $thisfn=declutter(shift);
1.31 www 1031: my %hash;
1.37 www 1032: my %bighash;
1033: my $syval='';
1.31 www 1034: if (($ENV{'request.course.fn'}) && ($ENV{'request.filename'})) {
1035: if (tie(%hash,'GDBM_File',$ENV{'request.course.fn'}.'_symb.db',
1036: &GDBM_READER,0640)) {
1037: $syval=$hash{$thisfn};
1.37 www 1038: untie(%hash);
1039: }
1040: # ---------------------------------------------------------- There was an entry
1041: if ($syval) {
1042: unless ($syval=~/\_\d+$/) {
1043: unless ($ENV{'form.request.prefix'}=~/\.(\d+)\_$/) {
1044: return '';
1045: }
1046: $syval.=$1;
1047: }
1048: } else {
1049: # ------------------------------------------------------- Was not in symb table
1050: if (tie(%bighash,'GDBM_File',$ENV{'request.course.fn'}.'.db',
1051: &GDBM_READER,0640)) {
1052: # ---------------------------------------------- Get ID(s) for current resource
1053: my $ids=$bighash{'ids_/res/'.$thisfn};
1054: if ($ids) {
1055: # ------------------------------------------------------------------- Has ID(s)
1056: my @possibilities=split(/\,/,$ids);
1.39 www 1057: if ($#possibilities==0) {
1058: # ----------------------------------------------- There is only one possibility
1.37 www 1059: my ($mapid,$resid)=split(/\./,$ids);
1060: $syval=declutter($bighash{'map_id_'.$mapid}).'___'.$resid;
1061: } else {
1.39 www 1062: # ------------------------------------------ There is more than one possibility
1063: my $realpossible=0;
1064: map {
1065: my $file=$bighash{'src_'.$_};
1066: if (&allowed('bre',$file)) {
1067: my ($mapid,$resid)=split(/\./,$_);
1068: if ($bighash{'map_type_'.$mapid} ne 'page') {
1069: $realpossible++;
1070: $syval=declutter($bighash{'map_id_'.$mapid}).
1071: '___'.$resid;
1072: }
1073: }
1074: } @possibilities;
1075: if ($realpossible!=1) { $syval=''; }
1.37 www 1076: }
1077: }
1078: untie(%bighash)
1079: }
1.31 www 1080: }
1.38 www 1081: if ($syval) { return $syval.'___'.$thisfn; }
1.31 www 1082: }
1083: return '';
1084: }
1085:
1086: # ---------------------------------------------------------- Return random seed
1087:
1.32 www 1088: sub numval {
1089: my $txt=shift;
1090: $txt=~tr/A-J/0-9/;
1091: $txt=~tr/a-j/0-9/;
1092: $txt=~tr/K-T/0-9/;
1093: $txt=~tr/k-t/0-9/;
1094: $txt=~tr/U-Z/0-5/;
1095: $txt=~tr/u-z/0-5/;
1096: $txt=~s/\D//g;
1097: return int($txt);
1098: }
1099:
1.31 www 1100: sub rndseed {
1101: my $symb;
1.37 www 1102: unless ($symb=&symbread($ENV{'request.filename'})) { return ''; }
1.32 www 1103: my $symbchck=unpack("%32C*",$symb);
1104: my $symbseed=numval($symb)%$symbchck;
1105: my $namechck=unpack("%32C*",$ENV{'user.name'});
1106: my $nameseed=numval($ENV{'user.name'})%$namechck;
1107: return int( $symbseed
1108: .$nameseed
1109: .unpack("%32C*",$ENV{'user.domain'})
1.33 www 1110: .unpack("%32C*",$ENV{'request.course.id'})
1.32 www 1111: .$namechck
1112: .$symbchck);
1.36 albertel 1113: }
1114:
1115: # ------------------------------------------------------------ Serves up a file
1116: # returns either the contents of the file or a -1
1117: sub getfile {
1118: my $file=shift;
1.37 www 1119: &repcopy($file);
1.36 albertel 1120: if (! -e $file ) { return -1; };
1121: my $fh=Apache::File->new($file);
1122: my $a='';
1123: while (<$fh>) { $a .=$_; }
1124: return $a
1125: }
1126:
1127: sub filelocation {
1128: my ($dir,$file) = @_;
1129: my $location;
1130: $file=~ s/^\s*(\S+)\s*$/$1/; ## strip off leading and trailing spaces
1131: $file=~s/^$perlvar{'lonDocRoot'}//;
1132: $file=~s:^/*res::;
1133: if ( !( $file =~ m:^/:) ) {
1134: $location = $dir. '/'.$file;
1135: } else {
1136: $location = '/home/httpd/html/res'.$file;
1137: }
1138: $location=~s://+:/:g; # remove duplicate /
1139: while ($location=~m:/../:) {$location=~ s:/[^/]+/\.\./:/:g;} #remove dir/..
1140:
1141: return $location;
1.31 www 1142: }
1143:
1144: # ------------------------------------------------------------- Declutters URLs
1145:
1146: sub declutter {
1147: my $thisfn=shift;
1148: $thisfn=~s/^$perlvar{'lonDocRoot'}//;
1149: $thisfn=~s/^\///;
1150: $thisfn=~s/^res\///;
1151: return $thisfn;
1.12 www 1152: }
1153:
1154: # -------------------------------------------------------- Escape Special Chars
1155:
1156: sub escape {
1157: my $str=shift;
1158: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
1159: return $str;
1160: }
1161:
1162: # ----------------------------------------------------- Un-Escape Special Chars
1163:
1164: sub unescape {
1165: my $str=shift;
1166: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
1167: return $str;
1168: }
1.11 www 1169:
1.1 albertel 1170: # ================================================================ Main Program
1171:
1172: sub BEGIN {
1173: if ($readit ne 'done') {
1174: # ------------------------------------------------------------ Read access.conf
1175: {
1176: my $config=Apache::File->new("/etc/httpd/conf/access.conf");
1177:
1178: while (my $configline=<$config>) {
1179: if ($configline =~ /PerlSetVar/) {
1180: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.8 www 1181: chomp($varvalue);
1.1 albertel 1182: $perlvar{$varname}=$varvalue;
1183: }
1184: }
1185: }
1186:
1187: # ------------------------------------------------------------- Read hosts file
1188: {
1189: my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
1190:
1191: while (my $configline=<$config>) {
1192: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
1193: $hostname{$id}=$name;
1194: $hostdom{$id}=$domain;
1195: if ($role eq 'library') { $libserv{$id}=$name; }
1196: }
1197: }
1198:
1199: # ------------------------------------------------------ Read spare server file
1200: {
1201: my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
1202:
1203: while (my $configline=<$config>) {
1204: chomp($configline);
1205: if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
1206: $spareid{$configline}=1;
1207: }
1208: }
1209: }
1.11 www 1210: # ------------------------------------------------------------ Read permissions
1211: {
1212: my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
1213:
1214: while (my $configline=<$config>) {
1215: chomp($configline);
1216: my ($role,$perm)=split(/ /,$configline);
1217: if ($perm ne '') { $pr{$role}=$perm; }
1218: }
1219: }
1220:
1221: # -------------------------------------------- Read plain texts for permissions
1222: {
1223: my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
1224:
1225: while (my $configline=<$config>) {
1226: chomp($configline);
1227: my ($short,$plain)=split(/:/,$configline);
1228: if ($plain ne '') { $prp{$short}=$plain; }
1.25 www 1229: }
1230: }
1231:
1232: # ------------------------------------------------------------- Read file types
1233: {
1234: my $config=Apache::File->new("$perlvar{'lonTabDir'}/filetypes.tab");
1235:
1236: while (my $configline=<$config>) {
1237: chomp($configline);
1238: my ($ending,$emb,@descr)=split(/\s+/,$configline);
1239: if ($descr[0] ne '') {
1240: $fe{$ending}=$emb;
1241: $fd{$ending}=join(' ',@descr);
1242: }
1.11 www 1243: }
1244: }
1245:
1.22 www 1246:
1.1 albertel 1247: $readit='done';
1.12 www 1248: &logthis('<font color=yellow>INFO: Read configuration</font>');
1.1 albertel 1249: }
1250: }
1251: 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