Annotation of loncom/lonnet/perl/lonnet.pm, revision 1.13
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
7: # allowed(short,url) : returns codes for allowed actions
8: # appendenv(hash) : adds hash to session environment
9: # store(hash) : stores hash permanently for this url
10: # restore : returns hash for this url
11: # eget(namesp,array) : returns hash with keys from array filled in from namesp
12: # get(namesp,array) : returns hash with keys from array filled in from namesp
13: # put(namesp,hash) : stores hash in namesp
14: #
1.1 albertel 15: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
1.5 www 16: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
1.8 www 17: # 11/8,11/16,11/18,11/22,11/23,12/22,
1.12 www 18: # 01/06,01/13,02/24,02/28,02/29,
19: # 03/01,03/02,03/06,03/07,03/13,
1.13 ! www 20: # 04/05,05/29 Gerd Kortemeyer
1.1 albertel 21:
22: package Apache::lonnet;
23:
24: use strict;
25: use Apache::File;
1.8 www 26: use LWP::UserAgent();
1.11 www 27: use vars
28: qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp $readit);
1.1 albertel 29: use IO::Socket;
1.8 www 30: use Apache::Constants qw(:common :http);
1.1 albertel 31:
32: # --------------------------------------------------------------------- Logging
33:
34: sub logthis {
35: my $message=shift;
36: my $execdir=$perlvar{'lonDaemons'};
37: my $now=time;
38: my $local=localtime($now);
39: my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
40: print $fh "$local ($$): $message\n";
41: return 1;
42: }
43:
44: sub logperm {
45: my $message=shift;
46: my $execdir=$perlvar{'lonDaemons'};
47: my $now=time;
48: my $local=localtime($now);
49: my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");
50: print $fh "$now:$message:$local\n";
51: return 1;
52: }
53:
54: # -------------------------------------------------- Non-critical communication
55: sub subreply {
56: my ($cmd,$server)=@_;
57: my $peerfile="$perlvar{'lonSockDir'}/$server";
58: my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
59: Type => SOCK_STREAM,
60: Timeout => 10)
61: or return "con_lost";
62: print $client "$cmd\n";
63: my $answer=<$client>;
1.9 www 64: if (!$answer) { $answer="con_lost"; }
1.1 albertel 65: chomp($answer);
66: return $answer;
67: }
68:
69: sub reply {
70: my ($cmd,$server)=@_;
71: my $answer=subreply($cmd,$server);
72: if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
1.12 www 73: if (($answer=~/^error:/) || ($answer=~/^refused/) ||
74: ($answer=~/^rejected/)) {
75: &logthis("<font color=blue>WARNING:".
76: " $cmd to $server returned $answer</font>");
77: }
1.1 albertel 78: return $answer;
79: }
80:
81: # ----------------------------------------------------------- Send USR1 to lonc
82:
83: sub reconlonc {
84: my $peerfile=shift;
85: &logthis("Trying to reconnect for $peerfile");
86: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
87: if (my $fh=Apache::File->new("$loncfile")) {
88: my $loncpid=<$fh>;
89: chomp($loncpid);
90: if (kill 0 => $loncpid) {
91: &logthis("lonc at pid $loncpid responding, sending USR1");
92: kill USR1 => $loncpid;
93: sleep 1;
94: if (-e "$peerfile") { return; }
95: &logthis("$peerfile still not there, give it another try");
96: sleep 5;
97: if (-e "$peerfile") { return; }
1.12 www 98: &logthis(
99: "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
1.1 albertel 100: } else {
1.12 www 101: &logthis(
102: "<font color=blue>WARNING:".
103: " lonc at pid $loncpid not responding, giving up</font>");
1.1 albertel 104: }
105: } else {
1.12 www 106: &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
1.1 albertel 107: }
108: }
109:
110: # ------------------------------------------------------ Critical communication
1.12 www 111:
1.1 albertel 112: sub critical {
113: my ($cmd,$server)=@_;
114: my $answer=reply($cmd,$server);
115: if ($answer eq 'con_lost') {
116: my $pingreply=reply('ping',$server);
117: &reconlonc("$perlvar{'lonSockDir'}/$server");
118: my $pongreply=reply('pong',$server);
119: &logthis("Ping/Pong for $server: $pingreply/$pongreply");
120: $answer=reply($cmd,$server);
121: if ($answer eq 'con_lost') {
122: my $now=time;
123: my $middlename=$cmd;
1.5 www 124: $middlename=substr($middlename,0,16);
1.1 albertel 125: $middlename=~s/\W//g;
126: my $dfilename=
127: "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";
128: {
129: my $dfh;
130: if ($dfh=Apache::File->new(">$dfilename")) {
1.7 www 131: print $dfh "$cmd\n";
1.1 albertel 132: }
133: }
134: sleep 2;
135: my $wcmd='';
136: {
137: my $dfh;
138: if ($dfh=Apache::File->new("$dfilename")) {
139: $wcmd=<$dfh>;
140: }
141: }
142: chomp($wcmd);
1.7 www 143: if ($wcmd eq $cmd) {
1.12 www 144: &logthis("<font color=blue>WARNING: ".
145: "Connection buffer $dfilename: $cmd</font>");
1.1 albertel 146: &logperm("D:$server:$cmd");
147: return 'con_delayed';
148: } else {
1.12 www 149: &logthis("<font color=red>CRITICAL:"
150: ." Critical connection failed: $server $cmd</font>");
1.1 albertel 151: &logperm("F:$server:$cmd");
152: return 'con_failed';
153: }
154: }
155: }
156: return $answer;
157: }
158:
1.5 www 159: # ---------------------------------------------------------- Append Environment
160:
161: sub appenv {
1.6 www 162: my %newenv=@_;
163: my @oldenv;
164: {
165: my $fh;
166: unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
1.5 www 167: return 'error';
1.6 www 168: }
169: @oldenv=<$fh>;
170: }
171: for (my $i=0; $i<=$#oldenv; $i++) {
172: chomp($oldenv[$i]);
1.9 www 173: if ($oldenv[$i] ne '') {
174: my ($name,$value)=split(/=/,$oldenv[$i]);
175: $newenv{$name}=$value;
176: }
1.6 www 177: }
178: {
179: my $fh;
180: unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
181: return 'error';
182: }
183: my $newname;
184: foreach $newname (keys %newenv) {
185: print $fh "$newname=$newenv{$newname}\n";
186: }
1.5 www 187: }
188: return 'ok';
189: }
1.1 albertel 190:
191: # ------------------------------ Find server with least workload from spare.tab
1.11 www 192:
1.1 albertel 193: sub spareserver {
194: my $tryserver;
195: my $spareserver='';
196: my $lowestserver=100;
197: foreach $tryserver (keys %spareid) {
198: my $answer=reply('load',$tryserver);
199: if (($answer =~ /\d/) && ($answer<$lowestserver)) {
200: $spareserver="http://$hostname{$tryserver}";
201: $lowestserver=$answer;
202: }
203: }
204: return $spareserver;
205: }
206:
207: # --------- Try to authenticate user from domain's lib servers (first this one)
1.11 www 208:
1.1 albertel 209: sub authenticate {
210: my ($uname,$upass,$udom)=@_;
1.12 www 211: $upass=escape($upass);
1.1 albertel 212: if (($perlvar{'lonRole'} eq 'library') &&
213: ($udom eq $perlvar{'lonDefDomain'})) {
1.3 www 214: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
1.2 www 215: if ($answer =~ /authorized/) {
1.9 www 216: if ($answer eq 'authorized') {
217: &logthis("User $uname at $udom authorized by local server");
218: return $perlvar{'lonHostID'};
219: }
220: if ($answer eq 'non_authorized') {
221: &logthis("User $uname at $udom rejected by local server");
222: return 'no_host';
223: }
1.2 www 224: }
1.1 albertel 225: }
226:
227: my $tryserver;
228: foreach $tryserver (keys %libserv) {
229: if ($hostdom{$tryserver} eq $udom) {
1.10 www 230: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
1.1 albertel 231: if ($answer =~ /authorized/) {
1.9 www 232: if ($answer eq 'authorized') {
233: &logthis("User $uname at $udom authorized by $tryserver");
234: return $tryserver;
235: }
236: if ($answer eq 'non_authorized') {
237: &logthis("User $uname at $udom rejected by $tryserver");
238: return 'no_host';
239: }
1.1 albertel 240: }
241: }
1.9 www 242: }
243: &logthis("User $uname at $udom could not be authenticated");
1.1 albertel 244: return 'no_host';
245: }
246:
247: # ---------------------- Find the homebase for a user from domain's lib servers
1.11 www 248:
1.1 albertel 249: sub homeserver {
250: my ($uname,$udom)=@_;
251:
252: my $index="$uname:$udom";
253: if ($homecache{$index}) { return "$homecache{$index}"; }
254:
255: my $tryserver;
256: foreach $tryserver (keys %libserv) {
257: if ($hostdom{$tryserver} eq $udom) {
258: my $answer=reply("home:$udom:$uname",$tryserver);
259: if ($answer eq 'found') {
260: $homecache{$index}=$tryserver;
261: return $tryserver;
262: }
263: }
264: }
265: return 'no_host';
266: }
267:
268: # ----------------------------- Subscribe to a resource, return URL if possible
1.11 www 269:
1.1 albertel 270: sub subscribe {
271: my $fname=shift;
272: my $author=$fname;
273: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
274: my ($udom,$uname)=split(/\//,$author);
275: my $home=homeserver($uname,$udom);
276: if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) {
277: return 'not_found';
278: }
279: my $answer=reply("sub:$fname",$home);
280: return $answer;
281: }
282:
1.8 www 283: # -------------------------------------------------------------- Replicate file
284:
285: sub repcopy {
286: my $filename=shift;
287: my $transname="$filename.in.transfer";
288: my $remoteurl=subscribe($filename);
289: if ($remoteurl eq 'con_lost') {
290: &logthis("Subscribe returned con_lost: $filename");
291: return HTTP_SERVICE_UNAVAILABLE;
292: } elsif ($remoteurl eq 'not_found') {
293: &logthis("Subscribe returned not_found: $filename");
294: return HTTP_NOT_FOUND;
295: } elsif ($remoteurl eq 'forbidden') {
296: &logthis("Subscribe returned forbidden: $filename");
297: return FORBIDDEN;
298: } else {
299: my @parts=split(/\//,$filename);
300: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
301: if ($path ne "$perlvar{'lonDocRoot'}/res") {
302: &logthis("Malconfiguration for replication: $filename");
303: return HTTP_BAD_REQUEST;
304: }
305: my $count;
306: for ($count=5;$count<$#parts;$count++) {
307: $path.="/$parts[$count]";
308: if ((-e $path)!=1) {
309: mkdir($path,0777);
310: }
311: }
312: my $ua=new LWP::UserAgent;
313: my $request=new HTTP::Request('GET',"$remoteurl");
314: my $response=$ua->request($request,$transname);
315: if ($response->is_error()) {
316: unlink($transname);
317: my $message=$response->status_line;
1.12 www 318: &logthis("<font color=blue>WARNING:"
319: ." LWP get: $message: $filename</font>");
1.8 www 320: return HTTP_SERVICE_UNAVAILABLE;
321: } else {
322: rename($transname,$filename);
323: return OK;
324: }
325: }
326: }
327:
1.9 www 328: # ----------------------------------------------------------------------- Store
329:
330: sub store {
331: my %storehash=shift;
1.12 www 332: my $namevalue='';
333: map {
334: $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
335: } keys %storehash;
336: $namevalue=~s/\&$//;
337: return reply("store:$ENV{'user.domain'}:$ENV{'user.name'}:"
338: ."$ENV{'user.class'}:$ENV{'request.filename'}:$namevalue",
339: "$ENV{'user.home'}");
1.9 www 340: }
341:
342: # --------------------------------------------------------------------- Restore
343:
344: sub restore {
1.12 www 345: my $answer=reply("restore:$ENV{'user.domain'}:$ENV{'user.name'}:"
346: ."$ENV{'user.class'}:$ENV{'request.filename'}",
347: "$ENV{'user.home'}");
348: my %returnhash=();
349: map {
350: my ($name,$value)=split(/\=/,$_);
351: $returnhash{&unescape($name)}=&unescape($value);
352: } split(/\&/,$answer);
1.13 ! www 353: return %returnhash;
1.9 www 354: }
1.1 albertel 355:
1.11 www 356: # -------------------------------------------------------- Get user priviledges
357:
358: sub rolesinit {
359: my ($domain,$username,$authhost)=@_;
360: my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12 www 361: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11 www 362: my %allroles=();
363: my %thesepriv=();
364: my $userroles='';
365: my $now=time;
366: my $thesestr;
367:
368: if ($rolesdump ne '') {
369: map {
1.12 www 370: if ($_!~/rolesdef\&/) {
1.11 www 371: my ($area,$role)=split(/=/,$_);
372: my ($trole,$tend,$tstart)=split(/_/,$role);
373: if ($tend!=0) {
374: if ($tend<$now) {
375: $trole='';
376: }
377: }
378: if ($tstart!=0) {
379: if ($tstart>$now) {
380: $trole='';
381: }
382: }
383: if (($area ne '') && ($trole ne '')) {
1.12 www 384: $userroles.='user.role.'.$trole.'.'.$area.'='.
385: $tstart.'.'.$tend."\n";
386: my ($tdummy,$tdomain,$trest)=split(/\//,$area);
387: if ($trole =~ /^cr\//) {
388: my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
389: my $homsvr=homeserver($rauthor,$rdomain);
390: if ($hostname{$homsvr} ne '') {
391: my $roledef=
392: reply("get:$rdomain:$rauthor:roles:rolesdef&$rrole",
393: $homsvr);
394: if (($roledef ne 'con_lost') && ($roledef ne '')) {
395: my ($syspriv,$dompriv,$coursepriv)=
396: split(/&&/,$roledef);
397: $allroles{'/'}.=':'.$syspriv;
398: if ($tdomain ne '') {
399: $allroles{'/'.$tdomain.'/'}.=':'.$dompriv;
400: if ($trest ne '') {
401: $allroles{$area}.=':'.$coursepriv;
402: }
403: }
404: }
1.11 www 405: }
1.12 www 406: } else {
407: $allroles{'/'}.=':'.$pr{$trole.':s'};
408: if ($tdomain ne '') {
409: $allroles{'/'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
410: if ($trest ne '') {
411: $allroles{$area}.=':'.$pr{$trole.':c'};
412: }
413: }
1.11 www 414: }
1.12 www 415: }
416: }
1.11 www 417: } split(/&/,$rolesdump);
418: map {
419: %thesepriv=();
420: map {
421: if ($_ ne '') {
422: my ($priviledge,$restrictions)=split(/&/,$_);
423: if ($restrictions eq '') {
424: $thesepriv{$priviledge}='F';
425: } else {
426: if ($thesepriv{$priviledge} ne 'F') {
427: $thesepriv{$priviledge}.=$restrictions;
428: }
429: }
430: }
431: } split(/:/,$allroles{$_});
432: $thesestr='';
433: map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
434: $userroles.='user.priv.'.$_.'='.$thesestr."\n";
435: } keys %allroles;
436: }
437: return $userroles;
438: }
439:
1.12 www 440: # --------------------------------------------------------------- get interface
441:
442: sub get {
443: my ($namespace,@storearr)=@_;
444: my $items='';
445: map {
446: $items.=escape($_).'&';
447: } @storearr;
448: $items=~s/\&$//;
449: my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
450: $ENV{'user.home'});
451: my @pairs=split(/\&/,$rep);
452: my %returnhash=();
453: map {
454: my ($key,$value)=split(/=/,$_);
455: $returnhash{unespace($key)}=unescape($value);
456: } @pairs;
457: return %returnhash;
458: }
459:
460: # --------------------------------------------------------------- put interface
461:
462: sub put {
463: my ($namespace,%storehash)=@_;
464: my $items='';
465: map {
466: $items.=escape($_).'='.escape($storehash{$_}).'&';
467: } keys %storehash;
468: $items=~s/\&$//;
469: return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
470: $ENV{'user.home'});
471: }
472:
473: # -------------------------------------------------------------- eget interface
474:
475: sub eget {
476: my ($namespace,@storearr)=@_;
477: my $items='';
478: map {
479: $items.=escape($_).'&';
480: } @storearr;
481: $items=~s/\&$//;
482: my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
483: $ENV{'user.home'});
484: my @pairs=split(/\&/,$rep);
485: my %returnhash=();
486: map {
487: my ($key,$value)=split(/=/,$_);
488: $returnhash{unespace($key)}=unescape($value);
489: } @pairs;
490: return %returnhash;
491: }
492:
493: # ------------------------------------------------- Check for a user priviledge
494:
495: sub allowed {
496: my ($priv,$uri)=@_;
497: $uri=~s/^\/res//;
498: $uri=~s/^\///;
499: my $thisallowed='';
500: if ($ENV{'user.priv./'}=~/$priv\&([^\:]*)/) {
501: $thisallowed.=$1;
502: }
503: if ($ENV{'user.priv./'.(split(/\//,$uri))[0].'/'}=~/$priv\&([^\:]*)/) {
504: $thisallowed.=$1;
505: }
506: if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) {
507: $thisallowed.=$1;
508: }
509: return $thisallowed;
510: }
511:
512: # ----------------------------------------------------------------- Define Role
513:
514: sub definerole {
515: if (allowed('mcr','/')) {
516: my ($rolename,$sysrole,$domrole,$courole)=@_;
517: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
518: "$ENV{'user.domain'}:$ENV{'user.name'}:".
519: "rolesdef&$rolename=$sysrole&&$domrole&&$courole";
520: return reply($command,$ENV{'user.home'});
521: } else {
522: return 'refused';
523: }
524: }
525:
526: # ------------------------------------------------------------------ Plain Text
527:
528: sub plaintext {
529: return $prp{$_};
530: }
531:
532: # ----------------------------------------------------------------- Assign Role
533:
534: sub assignrole {
535: }
536:
537: # -------------------------------------------------------- Escape Special Chars
538:
539: sub escape {
540: my $str=shift;
541: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
542: return $str;
543: }
544:
545: # ----------------------------------------------------- Un-Escape Special Chars
546:
547: sub unescape {
548: my $str=shift;
549: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
550: return $str;
551: }
1.11 www 552:
1.1 albertel 553: # ================================================================ Main Program
554:
555: sub BEGIN {
556: if ($readit ne 'done') {
557: # ------------------------------------------------------------ Read access.conf
558: {
559: my $config=Apache::File->new("/etc/httpd/conf/access.conf");
560:
561: while (my $configline=<$config>) {
562: if ($configline =~ /PerlSetVar/) {
563: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.8 www 564: chomp($varvalue);
1.1 albertel 565: $perlvar{$varname}=$varvalue;
566: }
567: }
568: }
569:
570: # ------------------------------------------------------------- Read hosts file
571: {
572: my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
573:
574: while (my $configline=<$config>) {
575: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
576: $hostname{$id}=$name;
577: $hostdom{$id}=$domain;
578: if ($role eq 'library') { $libserv{$id}=$name; }
579: }
580: }
581:
582: # ------------------------------------------------------ Read spare server file
583: {
584: my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
585:
586: while (my $configline=<$config>) {
587: chomp($configline);
588: if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
589: $spareid{$configline}=1;
590: }
591: }
592: }
1.11 www 593: # ------------------------------------------------------------ Read permissions
594: {
595: my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
596:
597: while (my $configline=<$config>) {
598: chomp($configline);
599: my ($role,$perm)=split(/ /,$configline);
600: if ($perm ne '') { $pr{$role}=$perm; }
601: }
602: }
603:
604: # -------------------------------------------- Read plain texts for permissions
605: {
606: my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
607:
608: while (my $configline=<$config>) {
609: chomp($configline);
610: my ($short,$plain)=split(/:/,$configline);
611: if ($plain ne '') { $prp{$short}=$plain; }
612: }
613: }
614:
1.1 albertel 615: $readit='done';
1.12 www 616: &logthis('<font color=yellow>INFO: Read configuration</font>');
1.1 albertel 617: }
618: }
619: 1;
1.11 www 620:
1.1 albertel 621:
622:
623:
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