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