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