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: #
15: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
16: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
17: # 11/8,11/16,11/18,11/22,11/23,12/22,
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
21:
22: package Apache::lonnet;
23:
24: use strict;
25: use Apache::File;
26: use LWP::UserAgent();
27: use vars
28: qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp $readit);
29: use IO::Socket;
30: use Apache::Constants qw(:common :http);
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>;
64: if (!$answer) { $answer="con_lost"; }
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); }
73: if (($answer=~/^error:/) || ($answer=~/^refused/) ||
74: ($answer=~/^rejected/)) {
75: &logthis("<font color=blue>WARNING:".
76: " $cmd to $server returned $answer</font>");
77: }
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; }
98: &logthis(
99: "<font color=blue>WARNING: $peerfile still not there, giving up</font>");
100: } else {
101: &logthis(
102: "<font color=blue>WARNING:".
103: " lonc at pid $loncpid not responding, giving up</font>");
104: }
105: } else {
106: &logthis('<font color=blue>WARNING: lonc not running, giving up</font>');
107: }
108: }
109:
110: # ------------------------------------------------------ Critical communication
111:
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;
124: $middlename=substr($middlename,0,16);
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")) {
131: print $dfh "$cmd\n";
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);
143: if ($wcmd eq $cmd) {
144: &logthis("<font color=blue>WARNING: ".
145: "Connection buffer $dfilename: $cmd</font>");
146: &logperm("D:$server:$cmd");
147: return 'con_delayed';
148: } else {
149: &logthis("<font color=red>CRITICAL:"
150: ." Critical connection failed: $server $cmd</font>");
151: &logperm("F:$server:$cmd");
152: return 'con_failed';
153: }
154: }
155: }
156: return $answer;
157: }
158:
159: # ---------------------------------------------------------- Append Environment
160:
161: sub appenv {
162: my %newenv=@_;
163: my @oldenv;
164: {
165: my $fh;
166: unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
167: return 'error';
168: }
169: @oldenv=<$fh>;
170: }
171: for (my $i=0; $i<=$#oldenv; $i++) {
172: chomp($oldenv[$i]);
173: if ($oldenv[$i] ne '') {
174: my ($name,$value)=split(/=/,$oldenv[$i]);
175: $newenv{$name}=$value;
176: }
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: }
187: }
188: return 'ok';
189: }
190:
191: # ------------------------------ Find server with least workload from spare.tab
192:
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)
208:
209: sub authenticate {
210: my ($uname,$upass,$udom)=@_;
211: $upass=escape($upass);
212: if (($perlvar{'lonRole'} eq 'library') &&
213: ($udom eq $perlvar{'lonDefDomain'})) {
214: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
215: if ($answer =~ /authorized/) {
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: }
224: }
225: }
226:
227: my $tryserver;
228: foreach $tryserver (keys %libserv) {
229: if ($hostdom{$tryserver} eq $udom) {
230: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
231: if ($answer =~ /authorized/) {
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: }
240: }
241: }
242: }
243: &logthis("User $uname at $udom could not be authenticated");
244: return 'no_host';
245: }
246:
247: # ---------------------- Find the homebase for a user from domain's lib servers
248:
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
269:
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:
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;
318: &logthis("<font color=blue>WARNING:"
319: ." LWP get: $message: $filename</font>");
320: return HTTP_SERVICE_UNAVAILABLE;
321: } else {
322: rename($transname,$filename);
323: return OK;
324: }
325: }
326: }
327:
328: # ----------------------------------------------------------------------- Store
329:
330: sub store {
331: my %storehash=shift;
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'}");
341: }
342:
343: # --------------------------------------------------------------------- Restore
344:
345: sub restore {
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;
355: }
356:
357: # -------------------------------------------------------- Get user priviledges
358:
359: sub rolesinit {
360: my ($domain,$username,$authhost)=@_;
361: my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
362: if (($rolesdump eq 'con_lost') || ($rolesdump eq '')) { return ''; }
363: my %allroles=();
364: my %thesepriv=();
365: my $userroles='';
366: my $now=time;
367: my $thesestr;
368:
369: if ($rolesdump ne '') {
370: map {
371: if ($_!~/rolesdef\&/) {
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 '')) {
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: }
406: }
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: }
415: }
416: }
417: }
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:
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: }
553:
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);
565: chomp($varvalue);
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: }
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:
616: $readit='done';
617: &logthis('<font color=yellow>INFO: Read configuration</font>');
618: }
619: }
620: 1;
621:
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