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