Annotation of loncom/lonnet/perl/lonnet.pm, revision 1.14
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.14 ! www 20: # 04/05,05/29,05/31,06/01,06/05 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.14 ! www 328: # ------------------------------------------------------------------------- Log
! 329:
! 330: sub log {
! 331: my ($dom,$nam,$hom,$what)=@_;
! 332: return reply("log:$dom:$nam:$what",$hom);
! 333: }
! 334:
1.9 www 335: # ----------------------------------------------------------------------- Store
336:
337: sub store {
338: my %storehash=shift;
1.12 www 339: my $namevalue='';
340: map {
341: $namevalue.=escape($_).'='.escape($storehash{$_}).'&';
342: } keys %storehash;
343: $namevalue=~s/\&$//;
344: return reply("store:$ENV{'user.domain'}:$ENV{'user.name'}:"
345: ."$ENV{'user.class'}:$ENV{'request.filename'}:$namevalue",
346: "$ENV{'user.home'}");
1.9 www 347: }
348:
349: # --------------------------------------------------------------------- Restore
350:
351: sub restore {
1.12 www 352: my $answer=reply("restore:$ENV{'user.domain'}:$ENV{'user.name'}:"
353: ."$ENV{'user.class'}:$ENV{'request.filename'}",
354: "$ENV{'user.home'}");
355: my %returnhash=();
356: map {
357: my ($name,$value)=split(/\=/,$_);
358: $returnhash{&unescape($name)}=&unescape($value);
359: } split(/\&/,$answer);
1.13 www 360: return %returnhash;
1.9 www 361: }
1.1 albertel 362:
1.11 www 363: # -------------------------------------------------------- Get user priviledges
364:
365: sub rolesinit {
366: my ($domain,$username,$authhost)=@_;
367: my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
1.12 www 368: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
1.11 www 369: my %allroles=();
370: my %thesepriv=();
371: my $userroles='';
372: my $now=time;
373: my $thesestr;
374:
375: if ($rolesdump ne '') {
376: map {
1.12 www 377: if ($_!~/rolesdef\&/) {
1.11 www 378: my ($area,$role)=split(/=/,$_);
379: my ($trole,$tend,$tstart)=split(/_/,$role);
380: if ($tend!=0) {
381: if ($tend<$now) {
382: $trole='';
383: }
384: }
385: if ($tstart!=0) {
386: if ($tstart>$now) {
387: $trole='';
388: }
389: }
390: if (($area ne '') && ($trole ne '')) {
1.12 www 391: $userroles.='user.role.'.$trole.'.'.$area.'='.
392: $tstart.'.'.$tend."\n";
393: my ($tdummy,$tdomain,$trest)=split(/\//,$area);
394: if ($trole =~ /^cr\//) {
395: my ($rdummy,$rdomain,$rauthor,$rrole)=split(/\//,$trole);
396: my $homsvr=homeserver($rauthor,$rdomain);
397: if ($hostname{$homsvr} ne '') {
398: my $roledef=
399: reply("get:$rdomain:$rauthor:roles:rolesdef&$rrole",
400: $homsvr);
401: if (($roledef ne 'con_lost') && ($roledef ne '')) {
402: my ($syspriv,$dompriv,$coursepriv)=
403: split(/&&/,$roledef);
404: $allroles{'/'}.=':'.$syspriv;
405: if ($tdomain ne '') {
406: $allroles{'/'.$tdomain.'/'}.=':'.$dompriv;
407: if ($trest ne '') {
408: $allroles{$area}.=':'.$coursepriv;
409: }
410: }
411: }
1.11 www 412: }
1.12 www 413: } else {
414: $allroles{'/'}.=':'.$pr{$trole.':s'};
415: if ($tdomain ne '') {
416: $allroles{'/'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
417: if ($trest ne '') {
418: $allroles{$area}.=':'.$pr{$trole.':c'};
419: }
420: }
1.11 www 421: }
1.12 www 422: }
423: }
1.11 www 424: } split(/&/,$rolesdump);
425: map {
426: %thesepriv=();
427: map {
428: if ($_ ne '') {
429: my ($priviledge,$restrictions)=split(/&/,$_);
430: if ($restrictions eq '') {
431: $thesepriv{$priviledge}='F';
432: } else {
433: if ($thesepriv{$priviledge} ne 'F') {
434: $thesepriv{$priviledge}.=$restrictions;
435: }
436: }
437: }
438: } split(/:/,$allroles{$_});
439: $thesestr='';
440: map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
441: $userroles.='user.priv.'.$_.'='.$thesestr."\n";
442: } keys %allroles;
443: }
444: return $userroles;
445: }
446:
1.12 www 447: # --------------------------------------------------------------- get interface
448:
449: sub get {
450: my ($namespace,@storearr)=@_;
451: my $items='';
452: map {
453: $items.=escape($_).'&';
454: } @storearr;
455: $items=~s/\&$//;
456: my $rep=reply("get:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
457: $ENV{'user.home'});
458: my @pairs=split(/\&/,$rep);
459: my %returnhash=();
460: map {
461: my ($key,$value)=split(/=/,$_);
462: $returnhash{unespace($key)}=unescape($value);
463: } @pairs;
464: return %returnhash;
465: }
466:
467: # --------------------------------------------------------------- put interface
468:
469: sub put {
470: my ($namespace,%storehash)=@_;
471: my $items='';
472: map {
473: $items.=escape($_).'='.escape($storehash{$_}).'&';
474: } keys %storehash;
475: $items=~s/\&$//;
476: return reply("put:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
477: $ENV{'user.home'});
478: }
479:
480: # -------------------------------------------------------------- eget interface
481:
482: sub eget {
483: my ($namespace,@storearr)=@_;
484: my $items='';
485: map {
486: $items.=escape($_).'&';
487: } @storearr;
488: $items=~s/\&$//;
489: my $rep=reply("eget:$ENV{'user.domain'}:$ENV{'user.name'}:$namespace:$items",
490: $ENV{'user.home'});
491: my @pairs=split(/\&/,$rep);
492: my %returnhash=();
493: map {
494: my ($key,$value)=split(/=/,$_);
495: $returnhash{unespace($key)}=unescape($value);
496: } @pairs;
497: return %returnhash;
498: }
499:
500: # ------------------------------------------------- Check for a user priviledge
501:
502: sub allowed {
503: my ($priv,$uri)=@_;
504: $uri=~s/^\/res//;
505: $uri=~s/^\///;
1.14 ! www 506: if ($uri=~/^adm\//) {
! 507: return 'F';
! 508: }
1.12 www 509: my $thisallowed='';
510: if ($ENV{'user.priv./'}=~/$priv\&([^\:]*)/) {
511: $thisallowed.=$1;
512: }
513: if ($ENV{'user.priv./'.(split(/\//,$uri))[0].'/'}=~/$priv\&([^\:]*)/) {
514: $thisallowed.=$1;
515: }
516: if ($ENV{'user.priv./'.$uri}=~/$priv\&([^\:]*)/) {
517: $thisallowed.=$1;
518: }
519: return $thisallowed;
520: }
521:
522: # ----------------------------------------------------------------- Define Role
523:
524: sub definerole {
525: if (allowed('mcr','/')) {
526: my ($rolename,$sysrole,$domrole,$courole)=@_;
527: my $command="encrypt:rolesput:$ENV{'user.domain'}:$ENV{'user.name'}:".
528: "$ENV{'user.domain'}:$ENV{'user.name'}:".
529: "rolesdef&$rolename=$sysrole&&$domrole&&$courole";
530: return reply($command,$ENV{'user.home'});
531: } else {
532: return 'refused';
533: }
534: }
535:
536: # ------------------------------------------------------------------ Plain Text
537:
538: sub plaintext {
539: return $prp{$_};
540: }
541:
542: # ----------------------------------------------------------------- Assign Role
543:
544: sub assignrole {
545: }
546:
547: # -------------------------------------------------------- Escape Special Chars
548:
549: sub escape {
550: my $str=shift;
551: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
552: return $str;
553: }
554:
555: # ----------------------------------------------------- Un-Escape Special Chars
556:
557: sub unescape {
558: my $str=shift;
559: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
560: return $str;
561: }
1.11 www 562:
1.1 albertel 563: # ================================================================ Main Program
564:
565: sub BEGIN {
566: if ($readit ne 'done') {
567: # ------------------------------------------------------------ Read access.conf
568: {
569: my $config=Apache::File->new("/etc/httpd/conf/access.conf");
570:
571: while (my $configline=<$config>) {
572: if ($configline =~ /PerlSetVar/) {
573: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
1.8 www 574: chomp($varvalue);
1.1 albertel 575: $perlvar{$varname}=$varvalue;
576: }
577: }
578: }
579:
580: # ------------------------------------------------------------- Read hosts file
581: {
582: my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
583:
584: while (my $configline=<$config>) {
585: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
586: $hostname{$id}=$name;
587: $hostdom{$id}=$domain;
588: if ($role eq 'library') { $libserv{$id}=$name; }
589: }
590: }
591:
592: # ------------------------------------------------------ Read spare server file
593: {
594: my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
595:
596: while (my $configline=<$config>) {
597: chomp($configline);
598: if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
599: $spareid{$configline}=1;
600: }
601: }
602: }
1.11 www 603: # ------------------------------------------------------------ Read permissions
604: {
605: my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
606:
607: while (my $configline=<$config>) {
608: chomp($configline);
609: my ($role,$perm)=split(/ /,$configline);
610: if ($perm ne '') { $pr{$role}=$perm; }
611: }
612: }
613:
614: # -------------------------------------------- Read plain texts for permissions
615: {
616: my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
617:
618: while (my $configline=<$config>) {
619: chomp($configline);
620: my ($short,$plain)=split(/:/,$configline);
621: if ($plain ne '') { $prp{$short}=$plain; }
622: }
623: }
624:
1.1 albertel 625: $readit='done';
1.12 www 626: &logthis('<font color=yellow>INFO: Read configuration</font>');
1.1 albertel 627: }
628: }
629: 1;
1.11 www 630:
1.1 albertel 631:
632:
633:
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