1: # The LearningOnline Network
2: # TCP networking package
3: # 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30,
4: # 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,
5: # 11/8,11/16,11/18,11/22,11/23,12/22,
6: # 01/06,01/13,02/24,02/28,02/29 Gerd Kortemeyer
7:
8: package Apache::lonnet;
9:
10: use strict;
11: use Apache::File;
12: use LWP::UserAgent();
13: use vars
14: qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp $readit);
15: use IO::Socket;
16: use Apache::Constants qw(:common :http);
17:
18: # --------------------------------------------------------------------- Logging
19:
20: sub logthis {
21: my $message=shift;
22: my $execdir=$perlvar{'lonDaemons'};
23: my $now=time;
24: my $local=localtime($now);
25: my $fh=Apache::File->new(">>$execdir/logs/lonnet.log");
26: print $fh "$local ($$): $message\n";
27: return 1;
28: }
29:
30: sub logperm {
31: my $message=shift;
32: my $execdir=$perlvar{'lonDaemons'};
33: my $now=time;
34: my $local=localtime($now);
35: my $fh=Apache::File->new(">>$execdir/logs/lonnet.perm.log");
36: print $fh "$now:$message:$local\n";
37: return 1;
38: }
39:
40: # -------------------------------------------------- Non-critical communication
41: sub subreply {
42: my ($cmd,$server)=@_;
43: my $peerfile="$perlvar{'lonSockDir'}/$server";
44: my $client=IO::Socket::UNIX->new(Peer =>"$peerfile",
45: Type => SOCK_STREAM,
46: Timeout => 10)
47: or return "con_lost";
48: print $client "$cmd\n";
49: my $answer=<$client>;
50: if (!$answer) { $answer="con_lost"; }
51: chomp($answer);
52: return $answer;
53: }
54:
55: sub reply {
56: my ($cmd,$server)=@_;
57: my $answer=subreply($cmd,$server);
58: if ($answer eq 'con_lost') { $answer=subreply($cmd,$server); }
59: return $answer;
60: }
61:
62: # ----------------------------------------------------------- Send USR1 to lonc
63:
64: sub reconlonc {
65: my $peerfile=shift;
66: &logthis("Trying to reconnect for $peerfile");
67: my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";
68: if (my $fh=Apache::File->new("$loncfile")) {
69: my $loncpid=<$fh>;
70: chomp($loncpid);
71: if (kill 0 => $loncpid) {
72: &logthis("lonc at pid $loncpid responding, sending USR1");
73: kill USR1 => $loncpid;
74: sleep 1;
75: if (-e "$peerfile") { return; }
76: &logthis("$peerfile still not there, give it another try");
77: sleep 5;
78: if (-e "$peerfile") { return; }
79: &logthis("$peerfile still not there, giving up");
80: } else {
81: &logthis("lonc at pid $loncpid not responding, giving up");
82: }
83: } else {
84: &logthis('lonc not running, giving up');
85: }
86: }
87:
88: # ------------------------------------------------------ Critical communication
89: sub critical {
90: my ($cmd,$server)=@_;
91: my $answer=reply($cmd,$server);
92: if ($answer eq 'con_lost') {
93: my $pingreply=reply('ping',$server);
94: &reconlonc("$perlvar{'lonSockDir'}/$server");
95: my $pongreply=reply('pong',$server);
96: &logthis("Ping/Pong for $server: $pingreply/$pongreply");
97: $answer=reply($cmd,$server);
98: if ($answer eq 'con_lost') {
99: my $now=time;
100: my $middlename=$cmd;
101: $middlename=substr($middlename,0,16);
102: $middlename=~s/\W//g;
103: my $dfilename=
104: "$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server";
105: {
106: my $dfh;
107: if ($dfh=Apache::File->new(">$dfilename")) {
108: print $dfh "$cmd\n";
109: }
110: }
111: sleep 2;
112: my $wcmd='';
113: {
114: my $dfh;
115: if ($dfh=Apache::File->new("$dfilename")) {
116: $wcmd=<$dfh>;
117: }
118: }
119: chomp($wcmd);
120: if ($wcmd eq $cmd) {
121: &logthis("Connection buffer $dfilename: $cmd");
122: &logperm("D:$server:$cmd");
123: return 'con_delayed';
124: } else {
125: &logthis("CRITICAL CONNECTION FAILED: $server $cmd");
126: &logperm("F:$server:$cmd");
127: return 'con_failed';
128: }
129: }
130: }
131: return $answer;
132: }
133:
134: # ---------------------------------------------------------- Append Environment
135:
136: sub appenv {
137: my %newenv=@_;
138: my @oldenv;
139: {
140: my $fh;
141: unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
142: return 'error';
143: }
144: @oldenv=<$fh>;
145: }
146: for (my $i=0; $i<=$#oldenv; $i++) {
147: chomp($oldenv[$i]);
148: if ($oldenv[$i] ne '') {
149: my ($name,$value)=split(/=/,$oldenv[$i]);
150: $newenv{$name}=$value;
151: }
152: }
153: {
154: my $fh;
155: unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) {
156: return 'error';
157: }
158: my $newname;
159: foreach $newname (keys %newenv) {
160: print $fh "$newname=$newenv{$newname}\n";
161: }
162: }
163: return 'ok';
164: }
165:
166: # ------------------------------ Find server with least workload from spare.tab
167:
168: sub spareserver {
169: my $tryserver;
170: my $spareserver='';
171: my $lowestserver=100;
172: foreach $tryserver (keys %spareid) {
173: my $answer=reply('load',$tryserver);
174: if (($answer =~ /\d/) && ($answer<$lowestserver)) {
175: $spareserver="http://$hostname{$tryserver}";
176: $lowestserver=$answer;
177: }
178: }
179: return $spareserver;
180: }
181:
182: # --------- Try to authenticate user from domain's lib servers (first this one)
183:
184: sub authenticate {
185: my ($uname,$upass,$udom)=@_;
186:
187: if (($perlvar{'lonRole'} eq 'library') &&
188: ($udom eq $perlvar{'lonDefDomain'})) {
189: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
190: if ($answer =~ /authorized/) {
191: if ($answer eq 'authorized') {
192: &logthis("User $uname at $udom authorized by local server");
193: return $perlvar{'lonHostID'};
194: }
195: if ($answer eq 'non_authorized') {
196: &logthis("User $uname at $udom rejected by local server");
197: return 'no_host';
198: }
199: }
200: }
201:
202: my $tryserver;
203: foreach $tryserver (keys %libserv) {
204: if ($hostdom{$tryserver} eq $udom) {
205: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
206: if ($answer =~ /authorized/) {
207: if ($answer eq 'authorized') {
208: &logthis("User $uname at $udom authorized by $tryserver");
209: return $tryserver;
210: }
211: if ($answer eq 'non_authorized') {
212: &logthis("User $uname at $udom rejected by $tryserver");
213: return 'no_host';
214: }
215: }
216: }
217: }
218: &logthis("User $uname at $udom could not be authenticated");
219: return 'no_host';
220: }
221:
222: # ---------------------- Find the homebase for a user from domain's lib servers
223:
224: sub homeserver {
225: my ($uname,$udom)=@_;
226:
227: my $index="$uname:$udom";
228: if ($homecache{$index}) { return "$homecache{$index}"; }
229:
230: my $tryserver;
231: foreach $tryserver (keys %libserv) {
232: if ($hostdom{$tryserver} eq $udom) {
233: my $answer=reply("home:$udom:$uname",$tryserver);
234: if ($answer eq 'found') {
235: $homecache{$index}=$tryserver;
236: return $tryserver;
237: }
238: }
239: }
240: return 'no_host';
241: }
242:
243: # ----------------------------- Subscribe to a resource, return URL if possible
244:
245: sub subscribe {
246: my $fname=shift;
247: my $author=$fname;
248: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
249: my ($udom,$uname)=split(/\//,$author);
250: my $home=homeserver($uname,$udom);
251: if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) {
252: return 'not_found';
253: }
254: my $answer=reply("sub:$fname",$home);
255: return $answer;
256: }
257:
258: # -------------------------------------------------------------- Replicate file
259:
260: sub repcopy {
261: my $filename=shift;
262: my $transname="$filename.in.transfer";
263: my $remoteurl=subscribe($filename);
264: if ($remoteurl eq 'con_lost') {
265: &logthis("Subscribe returned con_lost: $filename");
266: return HTTP_SERVICE_UNAVAILABLE;
267: } elsif ($remoteurl eq 'not_found') {
268: &logthis("Subscribe returned not_found: $filename");
269: return HTTP_NOT_FOUND;
270: } elsif ($remoteurl eq 'forbidden') {
271: &logthis("Subscribe returned forbidden: $filename");
272: return FORBIDDEN;
273: } else {
274: my @parts=split(/\//,$filename);
275: my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]";
276: if ($path ne "$perlvar{'lonDocRoot'}/res") {
277: &logthis("Malconfiguration for replication: $filename");
278: return HTTP_BAD_REQUEST;
279: }
280: my $count;
281: for ($count=5;$count<$#parts;$count++) {
282: $path.="/$parts[$count]";
283: if ((-e $path)!=1) {
284: mkdir($path,0777);
285: }
286: }
287: my $ua=new LWP::UserAgent;
288: my $request=new HTTP::Request('GET',"$remoteurl");
289: my $response=$ua->request($request,$transname);
290: if ($response->is_error()) {
291: unlink($transname);
292: my $message=$response->status_line;
293: &logthis("LWP GET: $message: $filename");
294: return HTTP_SERVICE_UNAVAILABLE;
295: } else {
296: rename($transname,$filename);
297: return OK;
298: }
299: }
300: }
301:
302: # ----------------------------------------------------------------------- Store
303:
304: sub store {
305: my %storehash=shift;
306: my $command="store:$ENV{'user.domain'}:$ENV{'user.name'}:"
307: ."$ENV{'user.class'}:$ENV{'request.filename'}:";
308: }
309:
310: # --------------------------------------------------------------------- Restore
311:
312: sub restore {
313: my $command="restore:$ENV{'user.domain'}:$ENV{'user.name'}:"
314: ."$ENV{'user.class'}:$ENV{'request.filename'}:";
315: }
316:
317: # -------------------------------------------------------- Get user priviledges
318:
319: sub rolesinit {
320: my ($domain,$username,$authhost)=@_;
321: my $rolesdump=reply("dump:$domain:$username:roles",$authhost);
322: my %allroles=();
323: my %thesepriv=();
324: my $userroles='';
325: my $now=time;
326: my $thesestr;
327:
328: &logthis("$domain, $username, $authhost, $rolesdump");
329:
330: if ($rolesdump ne '') {
331: map {
332: my ($area,$role)=split(/=/,$_);
333: my ($trole,$tend,$tstart)=split(/_/,$role);
334: if ($tend!=0) {
335: if ($tend<$now) {
336: $trole='';
337: }
338: }
339: if ($tstart!=0) {
340: if ($tstart>$now) {
341: $trole='';
342: }
343: }
344: if (($area ne '') && ($trole ne '')) {
345: $userroles.='user.role.'.$trole.'='.$area."\n";
346: my ($tdummy,$tdomain,$trest)=split(/\//,$area);
347: $allroles{'/'}.=':'.$pr{$trole.':s'};
348: if ($tdomain ne '') {
349: $allroles{'/'.$tdomain.'/'}.=':'.$pr{$trole.':d'};
350: if ($trest ne '') {
351: $allroles{$area}.=':'.$pr{$trole.':c'};
352: }
353: }
354: }
355: } split(/&/,$rolesdump);
356: map {
357: %thesepriv=();
358: map {
359: if ($_ ne '') {
360: my ($priviledge,$restrictions)=split(/&/,$_);
361: if ($restrictions eq '') {
362: $thesepriv{$priviledge}='F';
363: } else {
364: if ($thesepriv{$priviledge} ne 'F') {
365: $thesepriv{$priviledge}.=$restrictions;
366: }
367: }
368: }
369: } split(/:/,$allroles{$_});
370: $thesestr='';
371: map { $thesestr.=':'.$_.'&'.$thesepriv{$_}; } keys %thesepriv;
372: $userroles.='user.priv.'.$_.'='.$thesestr."\n";
373: } keys %allroles;
374: }
375: return $userroles;
376: }
377:
378:
379: # ================================================================ Main Program
380:
381: sub BEGIN {
382: if ($readit ne 'done') {
383: # ------------------------------------------------------------ Read access.conf
384: {
385: my $config=Apache::File->new("/etc/httpd/conf/access.conf");
386:
387: while (my $configline=<$config>) {
388: if ($configline =~ /PerlSetVar/) {
389: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
390: chomp($varvalue);
391: $perlvar{$varname}=$varvalue;
392: }
393: }
394: }
395:
396: # ------------------------------------------------------------- Read hosts file
397: {
398: my $config=Apache::File->new("$perlvar{'lonTabDir'}/hosts.tab");
399:
400: while (my $configline=<$config>) {
401: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
402: $hostname{$id}=$name;
403: $hostdom{$id}=$domain;
404: if ($role eq 'library') { $libserv{$id}=$name; }
405: }
406: }
407:
408: # ------------------------------------------------------ Read spare server file
409: {
410: my $config=Apache::File->new("$perlvar{'lonTabDir'}/spare.tab");
411:
412: while (my $configline=<$config>) {
413: chomp($configline);
414: if (($configline) && ($configline ne $perlvar{'lonHostID'})) {
415: $spareid{$configline}=1;
416: }
417: }
418: }
419: # ------------------------------------------------------------ Read permissions
420: {
421: my $config=Apache::File->new("$perlvar{'lonTabDir'}/roles.tab");
422:
423: while (my $configline=<$config>) {
424: chomp($configline);
425: my ($role,$perm)=split(/ /,$configline);
426: if ($perm ne '') { $pr{$role}=$perm; }
427: }
428: }
429:
430: # -------------------------------------------- Read plain texts for permissions
431: {
432: my $config=Apache::File->new("$perlvar{'lonTabDir'}/rolesplain.tab");
433:
434: while (my $configline=<$config>) {
435: chomp($configline);
436: my ($short,$plain)=split(/:/,$configline);
437: if ($plain ne '') { $prp{$short}=$plain; }
438: }
439: }
440:
441: $readit='done';
442: &logthis('Read configuration');
443: }
444: }
445: 1;
446:
447:
448:
449:
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