Annotation of loncom/lonnet/perl/lonnet.pm, revision 1.11
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,
1.11 ! www 6: # 01/06,01/13,02/24,02/28,02/29 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.11 ! www 13: use vars
! 14: qw(%perlvar %hostname %homecache %spareid %hostdom %libserv %pr %prp $readit);
1.1 albertel 15: use IO::Socket;
1.8 www 16: use Apache::Constants qw(:common :http);
1.1 albertel 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>;
1.9 www 50: if (!$answer) { $answer="con_lost"; }
1.1 albertel 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;
1.5 www 101: $middlename=substr($middlename,0,16);
1.1 albertel 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")) {
1.7 www 108: print $dfh "$cmd\n";
1.1 albertel 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);
1.7 www 120: if ($wcmd eq $cmd) {
1.1 albertel 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:
1.5 www 134: # ---------------------------------------------------------- Append Environment
135:
136: sub appenv {
1.6 www 137: my %newenv=@_;
138: my @oldenv;
139: {
140: my $fh;
141: unless ($fh=Apache::File->new("$ENV{'user.environment'}")) {
1.5 www 142: return 'error';
1.6 www 143: }
144: @oldenv=<$fh>;
145: }
146: for (my $i=0; $i<=$#oldenv; $i++) {
147: chomp($oldenv[$i]);
1.9 www 148: if ($oldenv[$i] ne '') {
149: my ($name,$value)=split(/=/,$oldenv[$i]);
150: $newenv{$name}=$value;
151: }
1.6 www 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: }
1.5 www 162: }
163: return 'ok';
164: }
1.1 albertel 165:
166: # ------------------------------ Find server with least workload from spare.tab
1.11 ! www 167:
1.1 albertel 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)
1.11 ! www 183:
1.1 albertel 184: sub authenticate {
185: my ($uname,$upass,$udom)=@_;
186:
187: if (($perlvar{'lonRole'} eq 'library') &&
188: ($udom eq $perlvar{'lonDefDomain'})) {
1.3 www 189: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'});
1.2 www 190: if ($answer =~ /authorized/) {
1.9 www 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: }
1.2 www 199: }
1.1 albertel 200: }
201:
202: my $tryserver;
203: foreach $tryserver (keys %libserv) {
204: if ($hostdom{$tryserver} eq $udom) {
1.10 www 205: my $answer=reply("encrypt:auth:$udom:$uname:$upass",$tryserver);
1.1 albertel 206: if ($answer =~ /authorized/) {
1.9 www 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: }
1.1 albertel 215: }
216: }
1.9 www 217: }
218: &logthis("User $uname at $udom could not be authenticated");
1.1 albertel 219: return 'no_host';
220: }
221:
222: # ---------------------- Find the homebase for a user from domain's lib servers
1.11 ! www 223:
1.1 albertel 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
1.11 ! www 244:
1.1 albertel 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:
1.8 www 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;
1.9 www 293: &logthis("LWP GET: $message: $filename");
1.8 www 294: return HTTP_SERVICE_UNAVAILABLE;
295: } else {
296: rename($transname,$filename);
297: return OK;
298: }
299: }
300: }
301:
1.9 www 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: }
1.1 albertel 316:
1.11 ! www 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:
1.1 albertel 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);
1.8 www 390: chomp($varvalue);
1.1 albertel 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: }
1.11 ! www 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:
1.1 albertel 441: $readit='done';
442: &logthis('Read configuration');
443: }
444: }
445: 1;
1.11 ! www 446:
1.1 albertel 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