version 1.2, 1999/11/08 16:20:35
|
version 1.9, 2000/01/14 21:12:40
|
Line 1
|
Line 1
|
# The LearningOnline Network |
# The LearningOnline Network |
# TCP networking package |
# TCP networking package |
# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, |
# 6/1/99,6/2,6/10,6/11,6/12,6/14,6/26,6/28,6/29,6/30, |
# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19,11/8 Gerd Kortemeyer |
# 7/1,7/2,7/9,7/10,7/12,7/14,7/15,7/19, |
|
# 11/8,11/16,11/18,11/22,11/23,12/22, |
|
# 01/06,01/13 Gerd Kortemeyer |
|
|
package Apache::lonnet; |
package Apache::lonnet; |
|
|
use strict; |
use strict; |
use Apache::File; |
use Apache::File; |
|
use LWP::UserAgent(); |
use vars qw(%perlvar %hostname %homecache %spareid %hostdom %libserv $readit); |
use vars qw(%perlvar %hostname %homecache %spareid %hostdom %libserv $readit); |
use IO::Socket; |
use IO::Socket; |
|
use Apache::Constants qw(:common :http); |
|
|
# --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
|
|
Line 42 sub subreply {
|
Line 46 sub subreply {
|
or return "con_lost"; |
or return "con_lost"; |
print $client "$cmd\n"; |
print $client "$cmd\n"; |
my $answer=<$client>; |
my $answer=<$client>; |
chomp($answer); |
|
if (!$answer) { $answer="con_lost"; } |
if (!$answer) { $answer="con_lost"; } |
|
chomp($answer); |
return $answer; |
return $answer; |
} |
} |
|
|
Line 54 sub reply {
|
Line 58 sub reply {
|
return $answer; |
return $answer; |
} |
} |
|
|
# ------------------------------------------------ Try to send delayed messages |
|
|
|
sub senddelayed { |
|
my $server=shift; |
|
my $dfname; |
|
my $path="$perlvar{'lonSockDir'}/delayed"; |
|
while ($dfname=<$path/*.$server>) { |
|
my $wcmd; |
|
{ |
|
my $dfh=Apache::File->new($dfname); |
|
$wcmd=<$dfh>; |
|
} |
|
my ($server,$cmd)=split(/:/,$wcmd); |
|
chomp($cmd); |
|
my $answer=subreply($cmd,$server); |
|
if ($answer ne 'con_lost') { |
|
unlink("$dfname"); |
|
&logthis("Delayed $cmd to $server: $answer"); |
|
&logperm("S:$server:$cmd"); |
|
} |
|
} |
|
} |
|
|
|
# ----------------------------------------------------------- Send USR1 to lonc |
# ----------------------------------------------------------- Send USR1 to lonc |
|
|
sub reconlonc { |
sub reconlonc { |
Line 106 sub reconlonc {
|
Line 87 sub reconlonc {
|
# ------------------------------------------------------ Critical communication |
# ------------------------------------------------------ Critical communication |
sub critical { |
sub critical { |
my ($cmd,$server)=@_; |
my ($cmd,$server)=@_; |
&senddelayed($server); |
|
my $answer=reply($cmd,$server); |
my $answer=reply($cmd,$server); |
if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
my $pingreply=reply('ping',$server); |
my $pingreply=reply('ping',$server); |
Line 117 sub critical {
|
Line 97 sub critical {
|
if ($answer eq 'con_lost') { |
if ($answer eq 'con_lost') { |
my $now=time; |
my $now=time; |
my $middlename=$cmd; |
my $middlename=$cmd; |
|
$middlename=substr($middlename,0,16); |
$middlename=~s/\W//g; |
$middlename=~s/\W//g; |
my $dfilename= |
my $dfilename= |
"$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server"; |
"$perlvar{'lonSockDir'}/delayed/$now.$middlename.$server"; |
{ |
{ |
my $dfh; |
my $dfh; |
if ($dfh=Apache::File->new(">$dfilename")) { |
if ($dfh=Apache::File->new(">$dfilename")) { |
print $dfh "$server:$cmd\n"; |
print $dfh "$cmd\n"; |
} |
} |
} |
} |
sleep 2; |
sleep 2; |
Line 135 sub critical {
|
Line 116 sub critical {
|
} |
} |
} |
} |
chomp($wcmd); |
chomp($wcmd); |
if ($wcmd eq "$server:$cmd") { |
if ($wcmd eq $cmd) { |
&logthis("Connection buffer $dfilename: $cmd"); |
&logthis("Connection buffer $dfilename: $cmd"); |
&logperm("D:$server:$cmd"); |
&logperm("D:$server:$cmd"); |
return 'con_delayed'; |
return 'con_delayed'; |
Line 149 sub critical {
|
Line 130 sub critical {
|
return $answer; |
return $answer; |
} |
} |
|
|
|
# ---------------------------------------------------------- Append Environment |
|
|
|
sub appenv { |
|
my %newenv=@_; |
|
my @oldenv; |
|
{ |
|
my $fh; |
|
unless ($fh=Apache::File->new("$ENV{'user.environment'}")) { |
|
return 'error'; |
|
} |
|
@oldenv=<$fh>; |
|
} |
|
for (my $i=0; $i<=$#oldenv; $i++) { |
|
chomp($oldenv[$i]); |
|
if ($oldenv[$i] ne '') { |
|
my ($name,$value)=split(/=/,$oldenv[$i]); |
|
$newenv{$name}=$value; |
|
} |
|
} |
|
{ |
|
my $fh; |
|
unless ($fh=Apache::File->new(">$ENV{'user.environment'}")) { |
|
return 'error'; |
|
} |
|
my $newname; |
|
foreach $newname (keys %newenv) { |
|
print $fh "$newname=$newenv{$newname}\n"; |
|
} |
|
} |
|
return 'ok'; |
|
} |
|
|
# ------------------------------ Find server with least workload from spare.tab |
# ------------------------------ Find server with least workload from spare.tab |
sub spareserver { |
sub spareserver { |
Line 171 sub authenticate {
|
Line 183 sub authenticate {
|
|
|
if (($perlvar{'lonRole'} eq 'library') && |
if (($perlvar{'lonRole'} eq 'library') && |
($udom eq $perlvar{'lonDefDomain'})) { |
($udom eq $perlvar{'lonDefDomain'})) { |
my $answer=reply("enc:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); |
my $answer=reply("encrypt:auth:$udom:$uname:$upass",$perlvar{'lonHostID'}); |
if ($answer =~ /authorized/) { |
if ($answer =~ /authorized/) { |
if ($answer eq 'authorized') { return $perlvar{'lonHostID'}; } |
if ($answer eq 'authorized') { |
if ($answer eq 'non_authorized') { return 'no_host'; } |
&logthis("User $uname at $udom authorized by local server"); |
|
return $perlvar{'lonHostID'}; |
|
} |
|
if ($answer eq 'non_authorized') { |
|
&logthis("User $uname at $udom rejected by local server"); |
|
return 'no_host'; |
|
} |
} |
} |
} |
} |
|
|
Line 183 sub authenticate {
|
Line 201 sub authenticate {
|
if ($hostdom{$tryserver} eq $udom) { |
if ($hostdom{$tryserver} eq $udom) { |
my $answer=reply("enc:auth:$udom:$uname:$upass",$tryserver); |
my $answer=reply("enc:auth:$udom:$uname:$upass",$tryserver); |
if ($answer =~ /authorized/) { |
if ($answer =~ /authorized/) { |
if ($answer eq 'authorized') { return $tryserver; } |
if ($answer eq 'authorized') { |
|
&logthis("User $uname at $udom authorized by $tryserver"); |
|
return $tryserver; |
|
} |
|
if ($answer eq 'non_authorized') { |
|
&logthis("User $uname at $udom rejected by $tryserver"); |
|
return 'no_host'; |
|
} |
} |
} |
} |
} |
} |
} |
|
&logthis("User $uname at $udom could not be authenticated"); |
return 'no_host'; |
return 'no_host'; |
} |
} |
|
|
Line 213 sub homeserver {
|
Line 239 sub homeserver {
|
# ----------------------------- Subscribe to a resource, return URL if possible |
# ----------------------------- Subscribe to a resource, return URL if possible |
sub subscribe { |
sub subscribe { |
my $fname=shift; |
my $fname=shift; |
&logthis($fname); |
|
my $author=$fname; |
my $author=$fname; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
$author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/; |
my ($udom,$uname)=split(/\//,$author); |
my ($udom,$uname)=split(/\//,$author); |
my $home=homeserver($uname,$udom); |
my $home=homeserver($uname,$udom); |
&logthis("$home $udom $uname"); |
|
if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { |
if (($home eq 'no_host') || ($home eq $perlvar{'lonHostID'})) { |
return 'not_found'; |
return 'not_found'; |
} |
} |
Line 226 sub subscribe {
|
Line 250 sub subscribe {
|
return $answer; |
return $answer; |
} |
} |
|
|
|
# -------------------------------------------------------------- Replicate file |
|
|
|
sub repcopy { |
|
my $filename=shift; |
|
my $transname="$filename.in.transfer"; |
|
my $remoteurl=subscribe($filename); |
|
if ($remoteurl eq 'con_lost') { |
|
&logthis("Subscribe returned con_lost: $filename"); |
|
return HTTP_SERVICE_UNAVAILABLE; |
|
} elsif ($remoteurl eq 'not_found') { |
|
&logthis("Subscribe returned not_found: $filename"); |
|
return HTTP_NOT_FOUND; |
|
} elsif ($remoteurl eq 'forbidden') { |
|
&logthis("Subscribe returned forbidden: $filename"); |
|
return FORBIDDEN; |
|
} else { |
|
my @parts=split(/\//,$filename); |
|
my $path="/$parts[1]/$parts[2]/$parts[3]/$parts[4]"; |
|
if ($path ne "$perlvar{'lonDocRoot'}/res") { |
|
&logthis("Malconfiguration for replication: $filename"); |
|
return HTTP_BAD_REQUEST; |
|
} |
|
my $count; |
|
for ($count=5;$count<$#parts;$count++) { |
|
$path.="/$parts[$count]"; |
|
if ((-e $path)!=1) { |
|
mkdir($path,0777); |
|
} |
|
} |
|
my $ua=new LWP::UserAgent; |
|
my $request=new HTTP::Request('GET',"$remoteurl"); |
|
my $response=$ua->request($request,$transname); |
|
if ($response->is_error()) { |
|
unlink($transname); |
|
my $message=$response->status_line; |
|
&logthis("LWP GET: $message: $filename"); |
|
return HTTP_SERVICE_UNAVAILABLE; |
|
} else { |
|
rename($transname,$filename); |
|
return OK; |
|
} |
|
} |
|
} |
|
|
|
# ----------------------------------------------------------------------- Store |
|
|
|
sub store { |
|
my %storehash=shift; |
|
my $command="store:$ENV{'user.domain'}:$ENV{'user.name'}:" |
|
."$ENV{'user.class'}:$ENV{'request.filename'}:"; |
|
} |
|
|
|
# --------------------------------------------------------------------- Restore |
|
|
|
sub restore { |
|
my $command="restore:$ENV{'user.domain'}:$ENV{'user.name'}:" |
|
."$ENV{'user.class'}:$ENV{'request.filename'}:"; |
|
} |
|
|
# ================================================================ Main Program |
# ================================================================ Main Program |
|
|
Line 238 if ($readit ne 'done') {
|
Line 320 if ($readit ne 'done') {
|
while (my $configline=<$config>) { |
while (my $configline=<$config>) { |
if ($configline =~ /PerlSetVar/) { |
if ($configline =~ /PerlSetVar/) { |
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); |
|
chomp($varvalue); |
$perlvar{$varname}=$varvalue; |
$perlvar{$varname}=$varvalue; |
} |
} |
} |
} |