loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.438 and 1.475

version 1.438, 2010/03/15 05:09:59	version 1.475, 2011/06/11 21:10:03
Line 15	Line 15
#	#
# LON-CAPA is distributed in the hope that it will be useful,	# LON-CAPA is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of	# but WITHOUT ANY WARRANTY; without even the implied warranty of

# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.	# GNU General Public License for more details.
#	#
Line 42 use Crypt::IDEA;	Line 43 use Crypt::IDEA;
use LWP::UserAgent();	use LWP::UserAgent();
use Digest::MD5 qw(md5_hex);	use Digest::MD5 qw(md5_hex);
use GDBM_File;	use GDBM_File;
use Authen::Krb4;
use Authen::Krb5;	use Authen::Krb5;
use localauth;	use localauth;
use localenroll;	use localenroll;
Line 53 use LONCAPA::lonlocal;	Line 53 use LONCAPA::lonlocal;
use LONCAPA::lonssl;	use LONCAPA::lonssl;
use Fcntl qw(:flock);	use Fcntl qw(:flock);
use Apache::lonnet;	use Apache::lonnet;
	use Mail::Send;

my $DEBUG = 0; # Non zero to enable debug log entries.	my $DEBUG = 0; # Non zero to enable debug log entries.

Line 67 my $currentdomainid;	Line 68 my $currentdomainid;
my $client;	my $client;
my $clientip; # IP address of client.	my $clientip; # IP address of client.
my $clientname; # LonCAPA name of client.	my $clientname; # LonCAPA name of client.
my $clientversion; # LonCAPA version running on client	my $clientversion; # LonCAPA version running on client.
	my $clienthomedom; # LonCAPA domain of homeID for client.
	# primary library server.

my $server;	my $server;

Line 418 sub ReadManagerTable {	Line 421 sub ReadManagerTable {

my $tablename = $perlvar{'lonTabDir'}."/managers.tab";	my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
if (!open (MANAGERS, $tablename)) {	if (!open (MANAGERS, $tablename)) {
logthis('<font color="red">No manager table. Nobody can manage!!</font>');	my $hostname = &Apache::lonnet::hostname($perlvar{'lonHostID'});
return;	if (&Apache::lonnet::is_LC_dns($hostname)) {
	&logthis('<font color="red">No manager table. Nobody can manage!!</font>');
	}
	return;
}	}
while(my $host = <MANAGERS>) {	while(my $host = <MANAGERS>) {
chomp($host);	chomp($host);
Line 444 sub ReadManagerTable {	Line 450 sub ReadManagerTable {
}	}
} else {	} else {
logthis('<font color="green"> existing host'." $host</font>\n");	logthis('<font color="green"> existing host'." $host</font>\n");
$managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if clumemeber	$managers{&Apache::lonnet::get_host_ip($host)} = $host; # Use info from cluster tab if cluster memeber
}	}
}	}
}	}
Line 506 sub AdjustHostContents {	Line 512 sub AdjustHostContents {
my $me = $perlvar{'lonHostID'};	my $me = $perlvar{'lonHostID'};

foreach my $line (split(/\n/,$contents)) {	foreach my $line (split(/\n/,$contents)) {
if(!(($line eq "") \|\| ($line =~ /^ \#/) \|\| ($line =~ /^ $/))) {	if(!(($line eq "") \|\| ($line =~ /^ \#/) \|\| ($line =~ /^ $/) \|\|
	($line =~ /^\s*\^/))) {
chomp($line);	chomp($line);
my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);	my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
if ($id eq $me) {	if ($id eq $me) {
Line 594 sub InstallFile {	Line 601 sub InstallFile {
#	#
# ConfigFileFromSelector: converts a configuration file selector	# ConfigFileFromSelector: converts a configuration file selector
# into a configuration file pathname.	# into a configuration file pathname.
# It's probably no longer necessary to preserve	# Supports the following file selectors:
# special handling of hosts or domain as those	# hosts, domain, dns_hosts, dns_domain
# files have been superceded by dns_hosts, dns_domain.
# The default action is just to prepend the directory
# and append .tab
#	#
#	#
# Parameters:	# Parameters:
Line 611 sub ConfigFileFromSelector {	Line 615 sub ConfigFileFromSelector {
my $tablefile;	my $tablefile;

my $tabledir = $perlvar{'lonTabDir'}.'/';	my $tabledir = $perlvar{'lonTabDir'}.'/';
if ($selector eq "hosts") {	if (($selector eq "hosts") \|\| ($selector eq "domain") \|\|
$tablefile = $tabledir."hosts.tab";	($selector eq "dns_hosts") \|\| ($selector eq "dns_domain")) {
} elsif ($selector eq "domain") {
$tablefile = $tabledir."domain.tab";
} else {
$tablefile = $tabledir.$selector.'.tab';	$tablefile = $tabledir.$selector.'.tab';
}	}
return $tablefile;	return $tablefile;

}	}
#	#
# PushFile: Called to do an administrative push of a file.	# PushFile: Called to do an administrative push of a file.
Line 645 sub PushFile {	Line 645 sub PushFile {
# supported:	# supported:
# hosts.tab ($filename eq host).	# hosts.tab ($filename eq host).
# domain.tab ($filename eq domain).	# domain.tab ($filename eq domain).
	# dns_hosts.tab ($filename eq dns_host).
	# dns_domain.tab ($filename eq dns_domain).
# Construct the destination filename or reject the request.	# Construct the destination filename or reject the request.
#	#
# lonManage is supposed to ensure this, however this session could be	# lonManage is supposed to ensure this, however this session could be
Line 676 sub PushFile {	Line 678 sub PushFile {
return "error:$!";	return "error:$!";
} else {	} else {
&logthis('<font color="green"> Installed new '.$tablefile	&logthis('<font color="green"> Installed new '.$tablefile
."</font>");	." - transaction by: $clientname ($clientip)</font>");
	my $adminmail = $perlvar{'lonAdmEMail'};
	my $admindom = &Apache::lonnet::host_domain($perlvar{'lonHostID'});
	if ($admindom ne '') {
	my %domconfig =
	&Apache::lonnet::get_dom('configuration',['contacts'],$admindom);
	if (ref($domconfig{'contacts'}) eq 'HASH') {
	if ($domconfig{'contacts'}{'adminemail'} ne '') {
	$adminmail = $domconfig{'contacts'}{'adminemail'};
	}
	}
	}
	if ($adminmail =~ /^[^\@]+\@[^\@]+$/) {
	my $msg = new Mail::Send;
	$msg->to($adminmail);
	$msg->subject('LON-CAPA DNS update on '.$perlvar{'lonHostID'});
	$msg->add('Content-type','text/plain; charset=UTF-8');
	if (my $fh = $msg->open()) {
	print $fh 'Update to '.$tablefile.' from Cluster Manager '.
	"$clientname ($clientip)\n";
	$fh->close;
	}
	}
}	}


# Indicate success:	# Indicate success:

return "ok";	return "ok";
Line 976 sub read_profile {	Line 998 sub read_profile {
&GDBM_READER());	&GDBM_READER());
if ($hashref) {	if ($hashref) {
my @queries=split(/\&/,$what);	my @queries=split(/\&/,$what);
	if ($namespace eq 'roles') {
	@queries = map { &unescape($_); } @queries;
	}
my $qresult='';	my $qresult='';

for (my $i=0;$i<=$#queries;$i++) {	for (my $i=0;$i<=$#queries;$i++) {
Line 1069 sub pong_handler {	Line 1094 sub pong_handler {
# Implicit Inputs:	# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host	# $currenthostid - Global variable that carries the name of the host
# known as.	# known as.
# $clientname - Global variable that carries the name of the hsot we're connected to.	# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:	# Returns:
# 1 - Ok to continue processing.	# 1 - Ok to continue processing.
# 0 - Program should exit.	# 0 - Program should exit.
Line 1108 sub establish_key_handler {	Line 1133 sub establish_key_handler {
# Implicit Inputs:	# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host	# $currenthostid - Global variable that carries the name of the host
# known as.	# known as.
# $clientname - Global variable that carries the name of the hsot we're connected to.	# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:	# Returns:
# 1 - Ok to continue processing.	# 1 - Ok to continue processing.
# 0 - Program should exit.	# 0 - Program should exit.
Line 1117 sub establish_key_handler {	Line 1142 sub establish_key_handler {
sub load_handler {	sub load_handler {
my ($cmd, $tail, $replyfd) = @_;	my ($cmd, $tail, $replyfd) = @_;



# Get the load average from /proc/loadavg and calculate it as a percentage of	# Get the load average from /proc/loadavg and calculate it as a percentage of
# the allowed load limit as set by the perl global variable lonLoadLim	# the allowed load limit as set by the perl global variable lonLoadLim

Line 1145 sub load_handler {	Line 1172 sub load_handler {
# Implicit Inputs:	# Implicit Inputs:
# $currenthostid - Global variable that carries the name of the host	# $currenthostid - Global variable that carries the name of the host
# known as.	# known as.
# $clientname - Global variable that carries the name of the hsot we're connected to.	# $clientname - Global variable that carries the name of the host we're connected to.
# Returns:	# Returns:
# 1 - Ok to continue processing.	# 1 - Ok to continue processing.
# 0 - Program should exit	# 0 - Program should exit
Line 1654 sub server_loncaparev_handler {	Line 1681 sub server_loncaparev_handler {
}	}
&register_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0);	&register_handler("serverloncaparev", \&server_loncaparev_handler, 0, 1, 0);

	sub server_homeID_handler {
	my ($cmd,$tail,$client) = @_;
	my $userinput = "$cmd:$tail";
	&Reply($client,\$perlvar{'lonHostID'},$userinput);
	return 1;
	}
	&register_handler("serverhomeID", \&server_homeID_handler, 0, 1, 0);

	sub server_distarch_handler {
	my ($cmd,$tail,$client) = @_;
	my $userinput = "$cmd:$tail";
	my $reply = &distro_and_arch();
	&Reply($client,\$reply,$userinput);
	return 1;
	}
	&register_handler("serverdistarch", \&server_distarch_handler, 0, 1, 0);

# Process a reinit request. Reinit requests that either	# Process a reinit request. Reinit requests that either
# lonc or lond be reinitialized so that an updated	# lonc or lond be reinitialized so that an updated
# host.tab or domain.tab can be processed.	# host.tab or domain.tab can be processed.
Line 1763 sub authenticate_handler {	Line 1807 sub authenticate_handler {
# upass - User's password.	# upass - User's password.
# checkdefauth - Pass to validate_user() to try authentication	# checkdefauth - Pass to validate_user() to try authentication
# with default auth type(s) if no user account.	# with default auth type(s) if no user account.
	# clientcancheckhost - Passed by clients with functionality in lonauth.pm
	# to check if session can be hosted.

my ($udom, $uname, $upass, $checkdefauth)=split(/:/,$tail);	my ($udom, $uname, $upass, $checkdefauth, $clientcancheckhost)=split(/:/,$tail);
&Debug(" Authenticate domain = $udom, user = $uname, password = $upass, checkdefauth = $checkdefauth");	&Debug(" Authenticate domain = $udom, user = $uname, password = $upass, checkdefauth = $checkdefauth");
chomp($upass);	chomp($upass);
$upass=&unescape($upass);	$upass=&unescape($upass);

my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);	my $pwdcorrect = &validate_user($udom,$uname,$upass,$checkdefauth);
if($pwdcorrect) {	if($pwdcorrect) {
&Reply( $client, "authorized\n", $userinput);	my $canhost = 1;
	unless ($clientcancheckhost) {
	my $uprimary_id = &Apache::lonnet::domain($udom,'primary');
	my $uint_dom = &Apache::lonnet::internet_dom($uprimary_id);
	my @intdoms;
	my $internet_names = &Apache::lonnet::get_internet_names($clientname);
	if (ref($internet_names) eq 'ARRAY') {
	@intdoms = @{$internet_names};
	}
	unless ($uint_dom ne '' && grep(/^\Q$uint_dom\E$/,@intdoms)) {
	my ($remote,$hosted);
	my $remotesession = &get_usersession_config($udom,'remotesession');
	if (ref($remotesession) eq 'HASH') {
	$remote = $remotesession->{'remote'}
	}
	my $hostedsession = &get_usersession_config($clienthomedom,'hostedsession');
	if (ref($hostedsession) eq 'HASH') {
	$hosted = $hostedsession->{'hosted'};
	}
	my $loncaparev = $clientversion;
	if ($loncaparev eq '') {
	$loncaparev = $Apache::lonnet::loncaparevs{$clientname};
	}
	$canhost = &Apache::lonnet::can_host_session($udom,$clientname,
	$loncaparev,
	$remote,$hosted);
	}
	}
	if ($canhost) {
	&Reply( $client, "authorized\n", $userinput);
	} else {
	&Reply( $client, "not_allowed_to_host\n", $userinput);
	}
#	#
# Bad credentials: Failed to authorize	# Bad credentials: Failed to authorize
#	#
Line 2109 sub update_resource_handler {	Line 2187 sub update_resource_handler {
my $transname="$fname.in.transfer";	my $transname="$fname.in.transfer";
my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");	my $remoteurl=&Apache::lonnet::reply("sub:$fname","$clientname");
my $response;	my $response;
alarm(120);	# FIXME: cannot replicate files that take more than two minutes to transfer?
	# alarm(120);
	# FIXME: this should use the LWP mechanism, not internal alarms.
	alarm(1200);
{	{
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
my $request=new HTTP::Request('GET',"$remoteurl");	my $request=new HTTP::Request('GET',"$remoteurl");
Line 2117 sub update_resource_handler {	Line 2198 sub update_resource_handler {
}	}
alarm(0);	alarm(0);
if ($response->is_error()) {	if ($response->is_error()) {
	# FIXME: we should probably clean up here instead of just whine
unlink($transname);	unlink($transname);
my $message=$response->status_line;	my $message=$response->status_line;
&logthis("LWP GET: $message for $fname ($remoteurl)");	&logthis("LWP GET: $message for $fname ($remoteurl)");
} else {	} else {
if ($remoteurl!~/\.meta$/) {	if ($remoteurl!~/\.meta$/) {
	# FIXME: isn't there an internal LWP mechanism for this?
alarm(120);	alarm(120);
{	{
my $ua=new LWP::UserAgent;	my $ua=new LWP::UserAgent;
Line 2371 sub user_has_session_handler {	Line 2454 sub user_has_session_handler {

my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));	my ($udom, $uname) = map { &unescape($_) } (split(/:/, $tail));

&logthis("Looking for $udom $uname");
opendir(DIR,$perlvar{'lonIDsDir'});	opendir(DIR,$perlvar{'lonIDsDir'});
my $filename;	my $filename;
while ($filename=readdir(DIR)) {	while ($filename=readdir(DIR)) {
Line 3102 sub dump_with_regexp {	Line 3184 sub dump_with_regexp {

my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";

my ($udom,$uname,$namespace,$regexp,$range)=split(/:/,$tail);	my ($udom,$uname,$namespace,$regexp,$range,$extra)=split(/:/,$tail);
if (defined($regexp)) {	if (defined($regexp)) {
$regexp=&unescape($regexp);	$regexp=&unescape($regexp);
} else {	} else {
Line 3120 sub dump_with_regexp {	Line 3202 sub dump_with_regexp {
}	}
my $hashref = &tie_user_hash($udom, $uname, $namespace,	my $hashref = &tie_user_hash($udom, $uname, $namespace,
&GDBM_READER());	&GDBM_READER());
	my $skipcheck;
if ($hashref) {	if ($hashref) {
my $qresult='';	my $qresult='';
my $count=0;	my $count=0;
	if ($extra ne '') {
	$extra = &Apache::lonnet::thaw_unescape($extra);
	$skipcheck = $extra->{'skipcheck'};
	}
	my @ids = &Apache::lonnet::current_machine_ids();
	my (%homecourses,$major,$minor,$now);
	if (($namespace eq 'roles') && (!$skipcheck)) {
	my $loncaparev = $clientversion;
	if ($loncaparev eq '') {
	$loncaparev = $Apache::lonnet::loncaparevs{$clientname};
	}
	if ($loncaparev =~ /^\'?(\d+)\.(\d+)\.[\w.\-]+\'?/) {
	$major = $1;
	$minor = $2;
	}
	$now = time;
	}
while (my ($key,$value) = each(%$hashref)) {	while (my ($key,$value) = each(%$hashref)) {
if ($namespace eq 'roles') {	if ($namespace eq 'roles') {
if ($key =~ /^($LONCAPA::match_domain)_($LONCAPA::match_community)_(cc\|co\|in\|ta\|ep\|ad\|st\|cr)/) {	if ($key =~ m{^/($LONCAPA::match_domain)/($LONCAPA::match_courseid)(/?[^_]*)_(cc\|co\|in\|ta\|ep\|ad\|st\|cr)$}) {
if ($clientversion =~ /^(\d+)\.(\d+)$/) {	my $cdom = $1;
my $major = $1;	my $cnum = $2;
my $minor = $2;	unless ($skipcheck) {
next if (($major < 2) \|\| (($major == 2) && ($minor < 9)));	my ($role,$end,$start) = split(/\_/,$value);
	if (!$end \|\| $end > $now) {
	next unless (&releasereqd_check($cnum,$cdom,$key,$value,$major,
	$minor,\%homecourses,\@ids));
	}
}	}
}	}
}	}
Line 3149 sub dump_with_regexp {	Line 3253 sub dump_with_regexp {
}	}
}	}
if (&untie_user_hash($hashref)) {	if (&untie_user_hash($hashref)) {
	if (($namespace eq 'roles') && (!$skipcheck)) {
	if (keys(%homecourses) > 0) {
	$qresult .= &check_homecourses(\%homecourses,$udom,$regexp,$count,
	$range,$start,$end,$major,$minor);
	}
	}
chop($qresult);	chop($qresult);
&Reply($client, \$qresult, $userinput);	&Reply($client, \$qresult, $userinput);
} else {	} else {
Line 3726 sub put_course_id_hash_handler {	Line 3836 sub put_course_id_hash_handler {
# createdafter - include courses for which creation date followed this date.	# createdafter - include courses for which creation date followed this date.
# creationcontext - include courses created in specified context	# creationcontext - include courses created in specified context
#	#
	# domcloner - flag to indicate if user can create CCs in course's domain.
	# If so, ability to clone course is automatic.
	#
# $client - The socket open on the client.	# $client - The socket open on the client.
# Returns:	# Returns:
# 1 - Continue processing.	# 1 - Continue processing.
Line 3738 sub dump_course_id_handler {	Line 3851 sub dump_course_id_handler {
my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,	my ($udom,$since,$description,$instcodefilter,$ownerfilter,$coursefilter,
$typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,	$typefilter,$regexp_ok,$rtn_as_hash,$selfenrollonly,$catfilter,$showhidden,
$caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,	$caller,$cloner,$cc_clone_list,$cloneonly,$createdbefore,$createdafter,
$creationcontext) =split(/:/,$tail);	$creationcontext,$domcloner) =split(/:/,$tail);
my $now = time;	my $now = time;
my ($cloneruname,$clonerudom,%cc_clone);	my ($cloneruname,$clonerudom,%cc_clone);
if (defined($description)) {	if (defined($description)) {
Line 3811 sub dump_course_id_handler {	Line 3924 sub dump_course_id_handler {
} else {	} else {
$creationcontext = '.';	$creationcontext = '.';
}	}

my $unpack = 1;	my $unpack = 1;
if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&	if ($description eq '.' && $instcodefilter eq '.' && $coursefilter eq '.' &&
$typefilter eq '.') {	$typefilter eq '.') {
Line 3842 sub dump_course_id_handler {	Line 3954 sub dump_course_id_handler {
next if ($since > 1);	next if ($since > 1);
}	}
$is_hash = 1;	$is_hash = 1;
if (defined($clonerudom)) {	if ($domcloner) {
	$canclone = 1;
	} elsif (defined($clonerudom)) {
if ($items->{'cloners'}) {	if ($items->{'cloners'}) {
my @cloneable = split(',',$items->{'cloners'});	my @cloneable = split(',',$items->{'cloners'});
if (@cloneable) {	if (@cloneable) {
Line 3875 sub dump_course_id_handler {	Line 3989 sub dump_course_id_handler {
if ($items->{'owner'} eq $cloner) {	if ($items->{'owner'} eq $cloner) {
$canclone = 1;	$canclone = 1;
}	}
} elsif ($cloner eq $udom.':'.$items->{'owner'}) {	} elsif ($cloner eq $items->{'owner'}.':'.$udom) {
$canclone = 1;	$canclone = 1;
}	}
if ($canclone) {	if ($canclone) {
Line 4195 sub put_domain_handler {	Line 4309 sub put_domain_handler {
sub get_domain_handler {	sub get_domain_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;


my $userinput = "$client:$tail";	my $userinput = "$client:$tail";

my ($udom,$namespace,$what)=split(/:/,$tail,3);	my ($udom,$namespace,$what)=split(/:/,$tail,3);
Line 4339 sub get_id_handler {	Line 4454 sub get_id_handler {
sub put_dcmail_handler {	sub put_dcmail_handler {
my ($cmd,$tail,$client) = @_;	my ($cmd,$tail,$client) = @_;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";


my ($udom,$what)=split(/:/,$tail);	my ($udom,$what)=split(/:/,$tail);
chomp($what);	chomp($what);
my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());	my $hashref = &tie_domain_hash($udom, "nohist_dcmail", &GDBM_WRCREAT());
Line 4603 sub tmp_put_handler {	Line 4719 sub tmp_put_handler {
}	}
my ($id,$store);	my ($id,$store);
$tmpsnum++;	$tmpsnum++;
if ($context eq 'resetpw') {	if (($context eq 'resetpw') \|\| ($context eq 'createaccount')) {
$id = &md5_hex(&md5_hex(time.{}.rand().$$));	$id = &md5_hex(&md5_hex(time.{}.rand().$$));
} else {	} else {
$id = $$.'_'.$clientip.'_'.$tmpsnum;	$id = $$.'_'.$clientip.'_'.$tmpsnum;
Line 4921 sub get_sections_handler {	Line 5037 sub get_sections_handler {
sub validate_course_owner_handler {	sub validate_course_owner_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;
my $userinput = "$cmd:$tail";	my $userinput = "$cmd:$tail";
my ($inst_course_id, $owner, $cdom) = split(/:/, $tail);	my ($inst_course_id, $owner, $cdom, $coowners) = split(/:/, $tail);

$owner = &unescape($owner);	$owner = &unescape($owner);
my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);	$coowners = &unescape($coowners);
	my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom,$coowners);
&Reply($client, \$outcome, $userinput);	&Reply($client, \$outcome, $userinput);


Line 5912 if (-e $pidfile) {	Line 6029 if (-e $pidfile) {
$server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},	$server = IO::Socket::INET->new(LocalPort => $perlvar{'londPort'},
Type => SOCK_STREAM,	Type => SOCK_STREAM,
Proto => 'tcp',	Proto => 'tcp',
Reuse => 1,	ReuseAddr => 1,
Listen => 10 )	Listen => 10 )
or die "making socket: $@\n";	or die "making socket: $@\n";

Line 5975 sub HUPSMAN { # sig	Line 6092 sub HUPSMAN { # sig
# a setuid perl script that can be root for us to do this job.	# a setuid perl script that can be root for us to do this job.
#	#
sub ReloadApache {	sub ReloadApache {
my $execdir = $perlvar{'lonDaemons'};	# --------------------------- Handle case of another apachereload process (locking)
my $script = $execdir."/apachereload";	if (&LONCAPA::try_to_lock('/tmp/lock_apachereload')) {
system($script);	my $execdir = $perlvar{'lonDaemons'};
	my $script = $execdir."/apachereload";
	system($script);
	unlink('/tmp/lock_apachereload'); # Remove the lock file.
	}
}	}

#	#
Line 6150 sub logstatus {	Line 6271 sub logstatus {
sub initnewstatus {	sub initnewstatus {
my $docdir=$perlvar{'lonDocRoot'};	my $docdir=$perlvar{'lonDocRoot'};
my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");	my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt");
my $now=time;	my $now=time();
my $local=localtime($now);	my $local=localtime($now);
print $fh "LOND status $local - parent $$\n\n";	print $fh "LOND status $local - parent $$\n\n";
opendir(DIR,"$docdir/lon-status/londchld");	opendir(DIR,"$docdir/lon-status/londchld");
Line 6239 $SIG{USR2} = \&UpdateHosts;	Line 6360 $SIG{USR2} = \&UpdateHosts;

# Read the host hashes:	# Read the host hashes:
&Apache::lonnet::load_hosts_tab();	&Apache::lonnet::load_hosts_tab();
	my %iphost = &Apache::lonnet::get_iphost(1);

my $dist=`$perlvar{'lonDaemons'}/distprobe`;	my $dist=`$perlvar{'lonDaemons'}/distprobe`;

	my $arch = `uname -i`;
	chomp($arch);
	if ($arch eq 'unknown') {
	$arch = `uname -m`;
	chomp($arch);
	}

# --------------------------------------------------------------	# --------------------------------------------------------------
# Accept connections. When a connection comes in, it is validated	# Accept connections. When a connection comes in, it is validated
# and if good, a child process is created to process transactions	# and if good, a child process is created to process transactions
Line 6299 sub make_new_child {	Line 6428 sub make_new_child {
or die "Can't unblock SIGINT for fork: $!\n";	or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = $clientip;	$children{$pid} = $clientip;
&status('Started child '.$pid);	&status('Started child '.$pid);
	close($client);
return;	return;
} else {	} else {
# Child can not return from this subroutine.	# Child can not return from this subroutine.
Line 6307 sub make_new_child {	Line 6437 sub make_new_child {
#don't get intercepted	#don't get intercepted
$SIG{USR1}= \&logstatus;	$SIG{USR1}= \&logstatus;
$SIG{ALRM}= \&timeout;	$SIG{ALRM}= \&timeout;
	#
	# Block sigpipe as it gets thrownon socket disconnect and we want to
	# deal with that as a read faiure instead.
	#
	my $blockset = POSIX::SigSet->new(SIGPIPE);
	sigprocmask(SIG_BLOCK, $blockset);

$lastlog='Forked ';	$lastlog='Forked ';
$status='Forked';	$status='Forked';

Line 6391 sub make_new_child {	Line 6528 sub make_new_child {
my $cipherkey = pack("H32", $key);	my $cipherkey = pack("H32", $key);
$cipher = new IDEA($cipherkey);	$cipher = new IDEA($cipherkey);
print $client "ok:local\n";	print $client "ok:local\n";
&logthis('<font color="green"'	&logthis('<font color="green">'
. "Successful local authentication </font>");	. "Successful local authentication </font>");
$keymode = "local"	$keymode = "local"
} else {	} else {
Line 6455 sub make_new_child {	Line 6592 sub make_new_child {
# ------------------------------------------------------------ Process requests	# ------------------------------------------------------------ Process requests
my $keep_going = 1;	my $keep_going = 1;
my $user_input;	my $user_input;
	my $clienthost = &Apache::lonnet::hostname($clientname);
	my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);
	$clienthomedom = &Apache::lonnet::host_domain($clientserverhomeID);
while(($user_input = get_request) && $keep_going) {	while(($user_input = get_request) && $keep_going) {
alarm(120);	alarm(120);
Debug("Main: Got $user_input\n");	Debug("Main: Got $user_input\n");
Line 6708 sub validate_user {	Line 6848 sub validate_user {
} else {	} else {
$validated = 0;	$validated = 0;
}	}
}	} elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.
elsif ($howpwd eq "krb4") { # user is in kerberos 4 auth. domain.	my $checkwithkrb5 = 0;
if(! ($password =~ /$null/) ) {	if ($dist =~/^fedora(\d+)$/) {
my $k4error = &Authen::Krb4::get_pw_in_tkt($user,	if ($1 > 11) {
"",	$checkwithkrb5 = 1;
$contentpwd,,	}
'krbtgt',	} elsif ($dist =~ /^suse([\d.]+)$/) {
$contentpwd,	if ($1 > 11.1) {
1,	$checkwithkrb5 = 1;
$password);	}
if(!$k4error) {	}
$validated = 1;	if ($checkwithkrb5) {
} else {	$validated = &krb5_authen($password,$null,$user,$contentpwd);
$validated = 0;	} else {
&logthis('krb4: '.$user.', '.$contentpwd.', '.	$validated = &krb4_authen($password,$null,$user,$contentpwd);
&Authen::Krb4::get_err_txt($Authen::Krb4::error));	}
}
} else {
$validated = 0; # Password has a match with null.
}
} elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.	} elsif ($howpwd eq "krb5") { # User is in kerberos 5 auth. domain.
if(!($password =~ /$null/)) { # Null password not allowed.	$validated = &krb5_authen($password,$null,$user,$contentpwd);
my $krbclient = &Authen::Krb5::parse_name($user.'@'
.$contentpwd);
my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
my $krbserver = &Authen::Krb5::parse_name($krbservice);
my $credentials= &Authen::Krb5::cc_default();
$credentials->initialize(&Authen::Krb5::parse_name($user.'@'
.$contentpwd));
my $krbreturn;
if (exists(&Authen::Krb5::get_init_creds_password)) {
$krbreturn =
&Authen::Krb5::get_init_creds_password($krbclient,$password,
$krbservice);
$validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
} else {
$krbreturn =
&Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
$password,$credentials);
$validated = ($krbreturn == 1);
}
if (!$validated) {
&logthis('krb5: '.$user.', '.$contentpwd.', '.
&Authen::Krb5::error());
}
} else {
$validated = 0;
}
} elsif ($howpwd eq "localauth") {	} elsif ($howpwd eq "localauth") {
# Authenticate via installation specific authentcation method:	# Authenticate via installation specific authentcation method:
$validated = &localauth::localauth($user,	$validated = &localauth::localauth($user,
Line 6786 sub validate_user {	Line 6896 sub validate_user {
return $validated;	return $validated;
}	}

	sub krb4_authen {
	my ($password,$null,$user,$contentpwd) = @_;
	my $validated = 0;
	if (!($password =~ /$null/) ) { # Null password not allowed.
	eval {
	require Authen::Krb4;
	};
	if (!$@) {
	my $k4error = &Authen::Krb4::get_pw_in_tkt($user,
	"",
	$contentpwd,,
	'krbtgt',
	$contentpwd,
	1,
	$password);
	if(!$k4error) {
	$validated = 1;
	} else {
	$validated = 0;
	&logthis('krb4: '.$user.', '.$contentpwd.', '.
	&Authen::Krb4::get_err_txt($Authen::Krb4::error));
	}
	} else {
	$validated = krb5_authen($password,$null,$user,$contentpwd);
	}
	}
	return $validated;
	}

	sub krb5_authen {
	my ($password,$null,$user,$contentpwd) = @_;
	my $validated = 0;
	if(!($password =~ /$null/)) { # Null password not allowed.
	my $krbclient = &Authen::Krb5::parse_name($user.'@'
	.$contentpwd);
	my $krbservice = "krbtgt/".$contentpwd."\@".$contentpwd;
	my $krbserver = &Authen::Krb5::parse_name($krbservice);
	my $credentials= &Authen::Krb5::cc_default();
	$credentials->initialize(&Authen::Krb5::parse_name($user.'@'
	.$contentpwd));
	my $krbreturn;
	if (exists(&Authen::Krb5::get_init_creds_password)) {
	$krbreturn =
	&Authen::Krb5::get_init_creds_password($krbclient,$password,
	$krbservice);
	$validated = (ref($krbreturn) eq 'Authen::Krb5::Creds');
	} else {
	$krbreturn =
	&Authen::Krb5::get_in_tkt_with_password($krbclient,$krbserver,
	$password,$credentials);
	$validated = ($krbreturn == 1);
	}
	if (!$validated) {
	&logthis('krb5: '.$user.', '.$contentpwd.', '.
	&Authen::Krb5::error());
	}
	}
	return $validated;
	}

sub addline {	sub addline {
my ($fname,$hostid,$ip,$newline)=@_;	my ($fname,$hostid,$ip,$newline)=@_;
Line 7156 sub sethost {	Line 7325 sub sethost {
eq &Apache::lonnet::get_host_ip($hostid)) {	eq &Apache::lonnet::get_host_ip($hostid)) {
$currenthostid =$hostid;	$currenthostid =$hostid;
$currentdomainid=&Apache::lonnet::host_domain($hostid);	$currentdomainid=&Apache::lonnet::host_domain($hostid);
&logthis("Setting hostid to $hostid, and domain to $currentdomainid");	# &logthis("Setting hostid to $hostid, and domain to $currentdomainid");
} else {	} else {
&logthis("Requested host id $hostid not an alias of ".	&logthis("Requested host id $hostid not an alias of ".
$perlvar{'lonHostID'}." refusing connection");	$perlvar{'lonHostID'}." refusing connection");
Line 7171 sub version {	Line 7340 sub version {
return "version:$VERSION";	return "version:$VERSION";
}	}

	sub get_usersession_config {
	my ($dom,$name) = @_;
	my ($usersessionconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
	if (defined($cached)) {
	return $usersessionconf;
	} else {
	my %domconfig = &Apache::lonnet::get_dom('configuration',['usersessions'],$dom);
	if (ref($domconfig{'usersessions'}) eq 'HASH') {
	&Apache::lonnet::do_cache_new($name,$dom,$domconfig{'usersessions'},3600);
	return $domconfig{'usersessions'};
	}
	}
	return;
	}

	sub releasereqd_check {
	my ($cnum,$cdom,$key,$value,$major,$minor,$homecourses,$ids) = @_;
	my $home = &Apache::lonnet::homeserver($cnum,$cdom);
	return if ($home eq 'no_host');
	my ($reqdmajor,$reqdminor,$displayrole);
	if ($cnum =~ /$LONCAPA::match_community/) {
	if ($major eq '' && $minor eq '') {
	return unless ((ref($ids) eq 'ARRAY') &&
	(grep(/^\Q$home\E$/,@{$ids})));
	} else {
	$reqdmajor = 2;
	$reqdminor = 9;
	return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
	}
	}
	my $hashid = $cdom.':'.$cnum;
	my ($courseinfo,$cached) =
	&Apache::lonnet::is_cached_new('courseinfo',$hashid);
	if (defined($cached)) {
	if (ref($courseinfo) eq 'HASH') {
	if (exists($courseinfo->{'releaserequired'})) {
	my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
	return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
	}
	}
	} else {
	if (ref($ids) eq 'ARRAY') {
	if (grep(/^\Q$home\E$/,@{$ids})) {
	if (ref($homecourses) eq 'HASH') {
	if (ref($homecourses->{$hashid}) eq 'ARRAY') {
	push(@{$homecourses->{$hashid}},{$key=>$value});
	} else {
	$homecourses->{$hashid} = [{$key=>$value}];
	}
	}
	return;
	}
	}
	my $courseinfo = &get_courseinfo_hash($cnum,$cdom,$home);
	if (ref($courseinfo) eq 'HASH') {
	if (exists($courseinfo->{'releaserequired'})) {
	my ($reqdmajor,$reqdminor) = split(/\./,$courseinfo->{'releaserequired'});
	return unless (&useable_role($reqdmajor,$reqdminor,$major,$minor));
	}
	} else {
	return;
	}
	}
	return 1;
	}

	sub get_courseinfo_hash {
	my ($cnum,$cdom,$home) = @_;
	my %info;
	eval {
	local($SIG{ALRM}) = sub { die "timeout\n"; };
	local($SIG{__DIE__})='DEFAULT';
	alarm(3);
	%info = &Apache::lonnet::courseiddump($cdom,'.',1,'.','.',$cnum,1,[$home],'.');
	alarm(0);
	};
	if ($@) {
	if ($@ eq "timeout\n") {
	&logthis("<font color='blue'>WARNING courseiddump for $cnum:$cdom from $home timedout</font>");
	} else {
	&logthis("<font color='yellow'>WARNING unexpected error during eval of call for courseiddump from $home</font>");
	}
	} else {
	if (ref($info{$cdom.'_'.$cnum}) eq 'HASH') {
	my $hashid = $cdom.':'.$cnum;
	return &Apache::lonnet::do_cache_new('courseinfo',$hashid,$info{$cdom.'_'.$cnum},600);
	}
	}
	return;
	}

	sub check_homecourses {
	my ($homecourses,$udom,$regexp,$count,$range,$start,$end,$major,$minor) = @_;
	my ($result,%addtocache);
	my $yesterday = time - 24*3600;
	if (ref($homecourses) eq 'HASH') {
	my (%okcourses,%courseinfo,%recent);
	my $hashref = &tie_domain_hash($udom, "nohist_courseids", &GDBM_WRCREAT());
	if ($hashref) {
	while (my ($key,$value) = each(%$hashref)) {
	my $unesc_key = &unescape($key);
	if ($unesc_key =~ /^lasttime:(\w+)$/) {
	my $cid = $1;
	$cid =~ s/_/:/;
	if ($value > $yesterday ) {
	$recent{$cid} = 1;
	}
	next;
	}
	my $items = &Apache::lonnet::thaw_unescape($value);
	if (ref($items) eq 'HASH') {
	my $hashid = $unesc_key;
	$hashid =~ s/_/:/;
	$courseinfo{$hashid} = $items;
	if (ref($homecourses->{$hashid}) eq 'ARRAY') {
	my ($reqdmajor,$reqdminor) = split(/\./,$items->{'releaserequired'});
	if (&useable_role($reqdmajor,$reqdminor,$major,$minor)) {
	$okcourses{$hashid} = 1;
	}
	}
	}
	}
	unless (&untie_domain_hash($hashref)) {
	&logthis('Failed to untie tied hash for nohist_courseids.db');
	}
	} else {
	&logthis('Failed to tie hash for nohist_courseids.db');
	return;
	}
	foreach my $hashid (keys(%recent)) {
	my ($result,$cached)=&Apache::lonnet::is_cached_new('courseinfo',$hashid);
	unless ($cached) {
	&Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
	}
	}
	foreach my $hashid (keys(%{$homecourses})) {
	next if ($recent{$hashid});
	&Apache::lonnet::do_cache_new('courseinfo',$hashid,$courseinfo{$hashid},600);
	}
	foreach my $hashid (keys(%okcourses)) {
	if (ref($homecourses->{$hashid}) eq 'ARRAY') {
	foreach my $role (@{$homecourses->{$hashid}}) {
	if (ref($role) eq 'HASH') {
	while (my ($key,$value) = each(%{$role})) {
	if ($regexp eq '.') {
	$count++;
	if (defined($range) && $count >= $end) { last; }
	if (defined($range) && $count < $start) { next; }
	$result.=$key.'='.$value.'&';
	} else {
	my $unescapeKey = &unescape($key);
	if (eval('$unescapeKey=~/$regexp/')) {
	$count++;
	if (defined($range) && $count >= $end) { last; }
	if (defined($range) && $count < $start) { next; }
	$result.="$key=$value&";
	}
	}
	}
	}
	}
	}
	}
	}
	return $result;
	}

	sub useable_role {
	my ($reqdmajor,$reqdminor,$major,$minor) = @_;
	if ($reqdmajor ne '' && $reqdminor ne '') {
	return if (($major eq '' && $minor eq '') \|\|
	($major < $reqdmajor) \|\|
	(($major == $reqdmajor) && ($minor < $reqdminor)));
	}
	return 1;
	}

	sub distro_and_arch {
	return $dist.':'.$arch;
	}

# ----------------------------------- POD (plain old documentation, CPAN style)	# ----------------------------------- POD (plain old documentation, CPAN style)

Line 7906 string.	Line 8255 string.

=back	=back

	=back


=cut	=cut

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>

Removed from v.1.438
changed lines
	Added in v.1.475