loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.531 and 1.546

version 1.531, 2017/02/07 18:14:13	version 1.546, 2018/08/09 13:27:55
Line 35 use LONCAPA;	Line 35 use LONCAPA;
use LONCAPA::Configuration;	use LONCAPA::Configuration;
use LONCAPA::Lond;	use LONCAPA::Lond;

	use Socket;
use IO::Socket;	use IO::Socket;
use IO::File;	use IO::File;
#use Apache::File;	#use Apache::File;
Line 75 my $clientname; # LonCAPA name of clie	Line 76 my $clientname; # LonCAPA name of clie
my $clientversion; # LonCAPA version running on client.	my $clientversion; # LonCAPA version running on client.
my $clienthomedom; # LonCAPA domain of homeID for client.	my $clienthomedom; # LonCAPA domain of homeID for client.
my $clientintdom; # LonCAPA "internet domain" for client.	my $clientintdom; # LonCAPA "internet domain" for client.
	my $clientsamedom; # LonCAPA domain same for this host
	# and client.
my $clientsameinst; # LonCAPA "internet domain" same for	my $clientsameinst; # LonCAPA "internet domain" same for
# this host and client.	# this host and client.
my $clientremoteok; # Client allowed to host domain's users.	my $clientremoteok; # Client allowed to host domain's users.
Line 102 my %managers; # Ip -> manager names	Line 105 my %managers; # Ip -> manager names

my %perlvar; # Will have the apache conf defined perl vars.	my %perlvar; # Will have the apache conf defined perl vars.

	my %secureconf; # Will have requirements for security
	# of lond connections

	my %crlchecked; # Will contain clients for which the client's SSL
	# has been checked against the cluster's Certificate
	# Revocation List.

my $dist;	my $dist;

#	#
Line 223 my %trust = (	Line 233 my %trust = (
dump => {remote => 1, enroll => 1, domroles => 1},	dump => {remote => 1, enroll => 1, domroles => 1},
edit => {institutiononly => 1}, #not used currently	edit => {institutiononly => 1}, #not used currently
eget => {remote => 1, domroles => 1, enroll => 1}, #not used currently	eget => {remote => 1, domroles => 1, enroll => 1}, #not used currently
	egetdom => {remote => 1, domroles => 1, enroll => 1, },
ekey => {}, #not used currently	ekey => {}, #not used currently
exit => {anywhere => 1},	exit => {anywhere => 1},
fetchuserfile => {remote => 1, enroll => 1},	fetchuserfile => {remote => 1, enroll => 1},
Line 259 my %trust = (	Line 270 my %trust = (
putstore => {remote => 1, enroll => 1},	putstore => {remote => 1, enroll => 1},
queryreply => {anywhere => 1},	queryreply => {anywhere => 1},
querysend => {anywhere => 1},	querysend => {anywhere => 1},
	querysend_activitylog => {remote => 1},
	querysend_allusers => {remote => 1, domroles => 1},
	querysend_courselog => {remote => 1},
	querysend_fetchenrollment => {remote => 1},
	querysend_getinstuser => {remote => 1},
	querysend_getmultinstusers => {remote => 1},
	querysend_instdirsearch => {remote => 1, domroles => 1, coaurem => 1},
	querysend_institutionalphotos => {remote => 1},
	querysend_portfolio_metadata => {remote => 1, content => 1},
	querysend_userlog => {remote => 1, domroles => 1},
	querysend_usersearch => {remote => 1, enroll => 1, coaurem => 1},
quit => {anywhere => 1},	quit => {anywhere => 1},
readlonnetglobal => {institutiononly => 1},	readlonnetglobal => {institutiononly => 1},
reinit => {manageronly => 1}, #not used currently	reinit => {manageronly => 1}, #not used currently
Line 402 sub SSLConnection {	Line 424 sub SSLConnection {
Debug("Approving promotion -> ssl");	Debug("Approving promotion -> ssl");
# And do so:	# And do so:

	my $CRLFile;
	unless ($crlchecked{$clientname}) {
	$CRLFile = lonssl::CRLFile();
	$crlchecked{$clientname} = 1;
	}

my $SSLSocket = lonssl::PromoteServerSocket($Socket,	my $SSLSocket = lonssl::PromoteServerSocket($Socket,
$CACertificate,	$CACertificate,
$Certificate,	$Certificate,
$KeyFile);	$KeyFile,
	$clientname,
	$CRLFile,
	$clientversion);
if(! ($SSLSocket) ) { # SSL socket promotion failed.	if(! ($SSLSocket) ) { # SSL socket promotion failed.
my $err = lonssl::LastError();	my $err = lonssl::LastError();
&logthis("<font color=\"red\"> CRITICAL "	&logthis("<font color=\"red\"> CRITICAL "
Line 445 sub InsecureConnection {	Line 476 sub InsecureConnection {
my $Socket = shift;	my $Socket = shift;

# Don't even start if insecure connections are not allowed.	# Don't even start if insecure connections are not allowed.
	# return 0 if Insecure connections not allowed.
if(! $perlvar{londAllowInsecure}) { # Insecure connections not allowed.	#
	if (ref($secureconf{'connfrom'}) eq 'HASH') {
	if ($clientsamedom) {
	if ($secureconf{'connfrom'}{'dom'} eq 'req') {
	return 0;
	}
	} elsif ($clientsameinst) {
	if ($secureconf{'connfrom'}{'intdom'} eq 'req') {
	return 0;
	}
	} else {
	if ($secureconf{'connfrom'}{'other'} eq 'req') {
	return 0;
	}
	}
	} elsif (!$perlvar{londAllowInsecure}) {
return 0;	return 0;
}	}

Line 1573 sub du2_handler {	Line 1619 sub du2_handler {
#	#
# 1. for a directory, and the path does not begin with one of:	# 1. for a directory, and the path does not begin with one of:
# (a) /home/httpd/html/res/<domain>	# (a) /home/httpd/html/res/<domain>
# (b) /home/httpd/html/res/userfiles/	# (b) /home/httpd/html/userfiles/
# (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles	# (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
# or is:	# or is:
#	#
# 2. for a file, and the path (after prepending) does not begin with:	# 2. for a file, and the path (after prepending) does not begin with one of:
# /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/	# (a) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/
	# (b) /home/httpd/html/res/<domain>/<username>/
	# (c) /home/httpd/html/userfiles/<domain>/<username>/
#	#
# the response will be "refused".	# the response will be "refused".
#	#
Line 1609 sub ls_handler {	Line 1657 sub ls_handler {
}	}
if (-e $ulsdir) {	if (-e $ulsdir) {
if(-d $ulsdir) {	if(-d $ulsdir) {
unless (($ulsdir =~ m{/home/httpd/html/(res/$LONCAPA::match_domain\|userfiles/)}) \|\|	unless (($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain\|userfiles/)}) \|\|
($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/userfiles/})) {	($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/userfiles})) {
&Failure($client,"refused\n",$userinput);	&Failure($client,"refused\n",$userinput);
return 1;	return 1;
}	}
Line 1637 sub ls_handler {	Line 1685 sub ls_handler {
closedir(LSDIR);	closedir(LSDIR);
}	}
} else {	} else {
unless ($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/}) {	unless (($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/}) \|\|
	($ulsdir =~ m{^/home/httpd/html/(?:res\|userfiles)/$LONCAPA::match_domain/$LONCAPA::match_name/})) {
&Failure($client,"refused\n",$userinput);	&Failure($client,"refused\n",$userinput);
return 1;	return 1;
}	}
Line 1670 sub ls_handler {	Line 1719 sub ls_handler {
#	#
# 1. for a directory, and the path does not begin with one of:	# 1. for a directory, and the path does not begin with one of:
# (a) /home/httpd/html/res/<domain>	# (a) /home/httpd/html/res/<domain>
# (b) /home/httpd/html/res/userfiles/	# (b) /home/httpd/html/userfiles/
# (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles	# (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
# or is:	# or is:
#	#
# 2. for a file, and the path (after prepending) does not begin with:	# 2. for a file, and the path (after prepending) does not begin with one of:
# /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/	# (a) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/
	# (b) /home/httpd/html/res/<domain>/<username>/
	# (c) /home/httpd/html/userfiles/<domain>/<username>/
#	#
# the response will be "refused".	# the response will be "refused".
#	#
Line 1705 sub ls2_handler {	Line 1756 sub ls2_handler {
}	}
if (-e $ulsdir) {	if (-e $ulsdir) {
if(-d $ulsdir) {	if(-d $ulsdir) {
unless (($ulsdir =~ m{/home/httpd/html/(res/$LONCAPA::match_domain\|userfiles/)}) \|\|	unless (($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain\|userfiles/)}) \|\|
($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/userfiles/})) {	($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/userfiles})) {
&Failure($client,"refused\n","$userinput");	&Failure($client,"refused\n","$userinput");
return 1;	return 1;
}	}
Line 1734 sub ls2_handler {	Line 1785 sub ls2_handler {
closedir(LSDIR);	closedir(LSDIR);
}	}
} else {	} else {
unless ($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/}) {	unless (($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/}) \|\|
	($ulsdir =~ m{^/home/httpd/html/(?:res\|userfiles)/$LONCAPA::match_domain/$LONCAPA::match_name/})) {
&Failure($client,"refused\n",$userinput);	&Failure($client,"refused\n",$userinput);
return 1;	return 1;
}	}
Line 1759 sub ls2_handler {	Line 1811 sub ls2_handler {
#	#
# 1. for a directory, and the path does not begin with one of:	# 1. for a directory, and the path does not begin with one of:
# (a) /home/httpd/html/res/<domain>	# (a) /home/httpd/html/res/<domain>
# (b) /home/httpd/html/res/userfiles/	# (b) /home/httpd/html/userfiles/
# (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles	# (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
# (d) /home/httpd/html/priv/<domain>/ and client is the homeserver	# (d) /home/httpd/html/priv/<domain> and client is the homeserver
#	#
# or is:	# or is:
#	#
# 2. for a file, and the path (after prepending) does not begin with:	# 2. for a file, and the path (after prepending) does not begin with one of:
# /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/	# (a) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/
	# (b) /home/httpd/html/res/<domain>/<username>/
	# (c) /home/httpd/html/userfiles/<domain>/<username>/
	# (d) /home/httpd/html/priv/<domain>/<username>/ and client is the homeserver
#	#
# the response will be "refused".	# the response will be "refused".
#	#
Line 1843 sub ls3_handler {	Line 1898 sub ls3_handler {
if (-e $ulsdir) {	if (-e $ulsdir) {
if(-d $ulsdir) {	if(-d $ulsdir) {
unless (($getpropath) \|\| ($getuserdir) \|\|	unless (($getpropath) \|\| ($getuserdir) \|\|
($ulsdir =~ m{/home/httpd/html/(res/$LONCAPA::match_domain\|userfiles/)}) \|\|	($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain\|userfiles/)}) \|\|
($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/userfiles/}) \|\|	($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/userfiles}) \|\|
(($ulsdir =~ m{/home/httpd/html/priv/$LONCAPA::match_domain/}) && ($islocal))) {	(($ulsdir =~ m{^/home/httpd/html/priv/$LONCAPA::match_domain}) && ($islocal))) {
&Failure($client,"refused\n",$userinput);	&Failure($client,"refused\n",$userinput);
return 1;	return 1;
}	}
Line 1874 sub ls3_handler {	Line 1929 sub ls3_handler {
}	}
} else {	} else {
unless (($getpropath) \|\| ($getuserdir) \|\|	unless (($getpropath) \|\| ($getuserdir) \|\|
($ulsdir =~ m{/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_username/})) {	($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/}) \|\|
	($ulsdir =~ m{^/home/httpd/html/(?:res\|userfiles)/$LONCAPA::match_domain/$LONCAPA::match_name/}) \|\|
	(($ulsdir =~ m{^/home/httpd/html/priv/$LONCAPA::match_domain/$LONCAPA::match_name/}) && ($islocal))) {
&Failure($client,"refused\n",$userinput);	&Failure($client,"refused\n",$userinput);
return 1;	return 1;
}	}
Line 2302 sub hash_passwd {	Line 2359 sub hash_passwd {
my $plainsalt = substr($rest[1],0,22);	my $plainsalt = substr($rest[1],0,22);
$salt = Crypt::Eksblowfish::Bcrypt::de_base64($plainsalt);	$salt = Crypt::Eksblowfish::Bcrypt::de_base64($plainsalt);
} else {	} else {
my $defaultcost;	my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
my %domconfig =	my $defaultcost = $domdefaults{'intauth_cost'};
&Apache::lonnet::get_dom('configuration',['password'],$domain);
if (ref($domconfig{'password'}) eq 'HASH') {
$defaultcost = $domconfig{'password'}{'cost'};
}
if (($defaultcost eq '') \|\| ($defaultcost =~ /D/)) {	if (($defaultcost eq '') \|\| ($defaultcost =~ /D/)) {
$cost = 10;	$cost = 10;
} else {	} else {
Line 2562 sub update_resource_handler {	Line 2615 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;
# FIXME: cannot replicate files that take more than two minutes to transfer?	# FIXME: cannot replicate files that take more than two minutes to transfer -- needs checking now 1200s timeout used
# alarm(120);	# for LWP request.
# FIXME: this should use the LWP mechanism, not internal alarms.	my $request=new HTTP::Request('GET',"$remoteurl");
alarm(1200);	$response=&LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,0,1);
{
my $request=new HTTP::Request('GET',"$remoteurl");
$response=&LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,0,1);
}
alarm(0);
if ($response->is_error()) {	if ($response->is_error()) {
# FIXME: we should probably clean up here instead of just whine	my $reply=&Apache::lonnet::reply("unsub:$fname","$clientname");
unlink($transname);	&devalidate_meta_cache($fname);
	if (-e $transname) {
	unlink($transname);
	}
	unlink($fname);
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?	my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');
alarm(120);	my $mresponse = &LONCAPA::LWPReq::makerequest($clientname,$mrequest,$fname.'.meta',\%perlvar,120,0,1);
{	if ($mresponse->is_error()) {
my $mrequest=new HTTP::Request('GET',$remoteurl.'.meta');	unlink($fname.'.meta');
my $mresponse = &LONCAPA::LWPReq::makerequest($clientname,$mrequest,$fname.'.meta',\%perlvar,120,0,1);
if ($mresponse->is_error()) {
unlink($fname.'.meta');
}
}	}
alarm(0);
}	}
# we successfully transfered, copy file over to real name	# we successfully transfered, copy file over to real name
rename($transname,$fname);	rename($transname,$fname);
Line 2657 sub fetch_user_file_handler {	Line 2704 sub fetch_user_file_handler {
my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;	my $remoteurl=$clientprotocol.'://'.$clienthost.'/userfiles/'.$fname;
my $response;	my $response;
Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");	Debug("Remote URL : $remoteurl Transfername $transname Destname: $destname");
alarm(1200);	my $request=new HTTP::Request('GET',"$remoteurl");
{	my $verifycert = 1;
my $request=new HTTP::Request('GET',"$remoteurl");	my @machine_ids = &Apache::lonnet::current_machine_ids();
my $verifycert = 1;	if (grep(/^\Q$clientname\E$/,@machine_ids)) {
my @machine_ids = &Apache::lonnet::current_machine_ids();	$verifycert = 0;
if (grep(/^\Q$clientname\E$/,@machine_ids)) {	}
$verifycert = 0;	$response = &LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,$verifycert);
}
$response = &LONCAPA::LWPReq::makerequest($clientname,$request,$transname,\%perlvar,1200,$verifycert);
}
alarm(0);
if ($response->is_error()) {	if ($response->is_error()) {
unlink($transname);	unlink($transname);
my $message=$response->status_line;	my $message=$response->status_line;
Line 3365 sub get_profile_entry {	Line 3408 sub get_profile_entry {
#	#
# Parameters:	# Parameters:
# $cmd - Command keyword of request (eget).	# $cmd - Command keyword of request (eget).
# $tail - Tail of the command. See GetProfileEntry # for more information about this.	# $tail - Tail of the command. See GetProfileEntry
	# for more information about this.
# $client - File open on the client.	# $client - File open on the client.
# Returns:	# Returns:
# 1 - Continue processing	# 1 - Continue processing
Line 3937 sub retrieve_chat_handler {	Line 3981 sub retrieve_chat_handler {
# serviced.	# serviced.
#	#
# Parameters:	# Parameters:
# $cmd - COmmand keyword that initiated the request.	# $cmd - Command keyword that initiated the request.
# $tail - Remainder of the command after the keyword.	# $tail - Remainder of the command after the keyword.
# For this function, this consists of a query and	# For this function, this consists of a query and
# 3 arguments that are self-documentingly labelled	# 3 arguments that are self-documentingly labelled
Line 3951 sub retrieve_chat_handler {	Line 3995 sub retrieve_chat_handler {
sub send_query_handler {	sub send_query_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;


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

my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);	my ($query,$arg1,$arg2,$arg3)=split(/\:/,$tail);
$query=~s/\n*$//g;	$query=~s/\n*$//g;
	if (($query eq 'usersearch') \|\| ($query eq 'instdirsearch')) {
	my $usersearchconf = &get_usersearch_config($currentdomainid,'directorysrch');
	my $earlyout;
	if (ref($usersearchconf) eq 'HASH') {
	if ($currentdomainid eq $clienthomedom) {
	if ($query eq 'usersearch') {
	if ($usersearchconf->{'lcavailable'} eq '0') {
	$earlyout = 1;
	}
	} else {
	if ($usersearchconf->{'available'} eq '0') {
	$earlyout = 1;
	}
	}
	} else {
	if ($query eq 'usersearch') {
	if ($usersearchconf->{'lclocalonly'}) {
	$earlyout = 1;
	}
	} else {
	if ($usersearchconf->{'localonly'}) {
	$earlyout = 1;
	}
	}
	}
	}
	if ($earlyout) {
	&Reply($client, "query_not_authorized\n");
	return 1;
	}
	}
&Reply($client, "". &sql_reply("$clientname\&$query".	&Reply($client, "". &sql_reply("$clientname\&$query".
"\&$arg1"."\&$arg2"."\&$arg3")."\n",	"\&$arg1"."\&$arg2"."\&$arg3")."\n",
$userinput);	$userinput);
Line 4818 sub get_domain_handler {	Line 4892 sub get_domain_handler {
my ($cmd, $tail, $client) = @_;	my ($cmd, $tail, $client) = @_;


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

	my ($udom,$namespace,$what)=split(/:/,$tail,3);
	chomp($what);
	if ($namespace =~ /^enc/) {
	&Failure( $client, "refused\n", $userinput);
	} else {
	my @queries=split(/\&/,$what);
	my $qresult='';
	my $hashref = &tie_domain_hash($udom, "$namespace", &GDBM_READER());
	if ($hashref) {
	for (my $i=0;$i<=$#queries;$i++) {
	$qresult.="$hashref->{$queries[$i]}&";
	}
	if (&untie_domain_hash($hashref)) {
	$qresult=~s/\&$//;
	&Reply($client, \$qresult, $userinput);
	} else {
	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
	"while attempting getdom\n",$userinput);
	}
	} else {
	&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
	"while attempting getdom\n",$userinput);
	}
	}

	return 1;
	}
	&register_handler("getdom", \&get_domain_handler, 0, 1, 0);

	sub encrypted_get_domain_handler {
	my ($cmd, $tail, $client) = @_;

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

my ($udom,$namespace,$what)=split(/:/,$tail,3);	my ($udom,$namespace,$what)=split(/:/,$tail,3);
chomp($what);	chomp($what);
Line 4831 sub get_domain_handler {	Line 4939 sub get_domain_handler {
}	}
if (&untie_domain_hash($hashref)) {	if (&untie_domain_hash($hashref)) {
$qresult=~s/\&$//;	$qresult=~s/\&$//;
&Reply($client, \$qresult, $userinput);	if ($cipher) {
	my $cmdlength=length($qresult);
	$qresult.=" ";
	my $encqresult='';
	for (my $encidx=0;$encidx<=$cmdlength;$encidx+=8) {
	$encqresult.= unpack("H16",
	$cipher->encrypt(substr($qresult,
	$encidx,
	8)));
	}
	&Reply( $client, "enc:$cmdlength:$encqresult\n", $userinput);
	} else {
	&Failure( $client, "error:no_key\n", $userinput);
	}
} else {	} else {
&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".	&Failure( $client, "error: ".($!+0)." untie(GDBM) Failed ".
"while attempting getdom\n",$userinput);	"while attempting egetdom\n",$userinput);
}	}
} else {	} else {
&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".	&Failure($client, "error: ".($!+0)." tie(GDBM) Failed ".
"while attempting getdom\n",$userinput);	"while attempting egetdom\n",$userinput);
}	}

return 1;	return 1;
}	}
&register_handler("getdom", \&get_domain_handler, 0, 1, 0);	&register_handler("egetdom", \&encrypted_get_domain_handler, 1, 1, 0);

#	#
# Puts an id to a domains id database.	# Puts an id to a domains id database.
Line 5639 sub validate_course_section_handler {	Line 5759 sub validate_course_section_handler {
# Formal Parameters:	# Formal Parameters:
# $cmd - The command request that got us dispatched.	# $cmd - The command request that got us dispatched.
# $tail - The tail of the command. In this case this is a colon separated	# $tail - The tail of the command. In this case this is a colon separated
# set of words that will be split into:	# set of values that will be split into:
# $inst_class - Institutional code for the specific class section	# $inst_class - Institutional code for the specific class section
# $courseowner - The escaped username:domain of the course owner	# $ownerlist - An escaped comma-separated list of username:domain
	# of the course owner, and co-owner(s).
# $cdom - The domain of the course from the institution's	# $cdom - The domain of the course from the institution's
# point of view.	# point of view.
# $client - The socket open on the client.	# $client - The socket open on the client.
Line 5666 sub validate_class_access_handler {	Line 5787 sub validate_class_access_handler {
&register_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0);	&register_handler("autovalidateclass_sec", \&validate_class_access_handler, 0, 1, 0);

#	#
	# Validate course owner or co-owners(s) access to enrollment data for all sections
	# and crosslistings for a particular course.
	#
	#
	# Formal Parameters:
	# $cmd - The command request that got us dispatched.
	# $tail - The tail of the command. In this case this is a colon separated
	# set of values that will be split into:
	# $ownerlist - An escaped comma-separated list of username:domain
	# of the course owner, and co-owner(s).
	# $cdom - The domain of the course from the institution's
	# point of view.
	# $classes - Frozen hash of institutional course sections and
	# crosslistings.
	# $client - The socket open on the client.
	# Returns:
	# 1 - continue processing.
	#

	sub validate_classes_handler {
	my ($cmd, $tail, $client) = @_;
	my $userinput = "$cmd:$tail";
	my ($ownerlist,$cdom,$classes) = split(/:/, $tail);
	my $classesref = &Apache::lonnet::thaw_unescape($classes);
	my $owners = &unescape($ownerlist);
	my $result;
	eval {
	local($SIG{__DIE__})='DEFAULT';
	my %validations;
	my $response = &localenroll::check_instclasses($owners,$cdom,$classesref,
	\%validations);
	if ($response eq 'ok') {
	foreach my $key (keys(%validations)) {
	$result .= &escape($key).'='.&Apache::lonnet::freeze_escape($validations{$key}).'&';
	}
	$result =~ s/\&$//;
	} else {
	$result = 'error';
	}
	};
	if (!$@) {
	&Reply($client, \$result, $userinput);
	} else {
	&Failure($client,"unknown_cmd\n",$userinput);
	}
	return 1;
	}
	&register_handler("autovalidateinstclasses", \&validate_classes_handler, 0, 1, 0);

	#
# Create a password for a new LON-CAPA user added by auto-enrollment.	# Create a password for a new LON-CAPA user added by auto-enrollment.
# Only used for case where authentication method for new user is localauth	# Only used for case where authentication method for new user is localauth
#	#
Line 5743 sub auto_export_grades_handler {	Line 5914 sub auto_export_grades_handler {
return 1;	return 1;
}	}
&register_handler("autoexportgrades", \&auto_export_grades_handler,	&register_handler("autoexportgrades", \&auto_export_grades_handler,
0, 1, 0);	1, 1, 0);

# Retrieve and remove temporary files created by/during autoenrollment.	# Retrieve and remove temporary files created by/during autoenrollment.
#	#
Line 6494 sub process_request {	Line 6665 sub process_request {
$ok = 0;	$ok = 0;
}	}
if ($ok) {	if ($ok) {
	my $realcommand = $command;
	if ($command eq 'querysend') {
	my ($query,$rest)=split(/\:/,$tail,2);
	$query=~s/\n*$//g;
	my @possqueries =
	qw(userlog courselog fetchenrollment institutionalphotos usersearch instdirsearch getinstuser getmultinstusers);
	if (grep(/^\Q$query\E$/,@possqueries)) {
	$command .= '_'.$query;
	} elsif ($query eq 'prepare activity log') {
	$command .= '_activitylog';
	}
	}
if (ref($trust{$command}) eq 'HASH') {	if (ref($trust{$command}) eq 'HASH') {
my $donechecks;	my $donechecks;
if ($trust{$command}{'anywhere'}) {	if ($trust{$command}{'anywhere'}) {
Line 6535 sub process_request {	Line 6718 sub process_request {
}	}
}	}
}	}
	$command = $realcommand;
}	}

if($ok) {	if($ok) {
Line 6803 sub UpdateHosts {	Line 6987 sub UpdateHosts {
# will take care of new and changed hosts as connections come into being.	# will take care of new and changed hosts as connections come into being.

&Apache::lonnet::reset_hosts_info();	&Apache::lonnet::reset_hosts_info();
	my %active;

foreach my $child (keys(%children)) {	foreach my $child (keys(%children)) {
my $childip = $children{$child};	my $childip = $children{$child};
Line 6812 sub UpdateHosts {	Line 6997 sub UpdateHosts {
." $child for ip $childip </font>");	." $child for ip $childip </font>");
kill('INT', $child);	kill('INT', $child);
} else {	} else {
	$active{$child} = $childip;
logthis('<font color="green"> keeping child for ip '	logthis('<font color="green"> keeping child for ip '
." $childip (pid=$child) </font>");	." $childip (pid=$child) </font>");
}	}
}	}

	my %oldconf = %secureconf;
	my %connchange;
	if (lonssl::Read_Connect_Config(\%secureconf,\%crlchecked,\%perlvar) eq 'ok') {
	logthis('<font color="blue"> Reloaded SSL connection rules and cleared CRL checking history </font>');
	} else {
	logthis('<font color="yellow"> Failed to reload SSL connection rules and clear CRL checking history </font>');
	}
	if ((ref($oldconf{'connfrom'}) eq 'HASH') && (ref($secureconf{'connfrom'}) eq 'HASH')) {
	foreach my $type ('dom','intdom','other') {
	if ((($oldconf{'connfrom'}{$type} eq 'no') && ($secureconf{'connfrom'}{$type} eq 'req')) \|\|
	(($oldconf{'connfrom'}{$type} eq 'req') && ($secureconf{'connfrom'}{$type} eq 'no'))) {
	$connchange{$type} = 1;
	}
	}
	}
	if (keys(%connchange)) {
	foreach my $child (keys(%active)) {
	my $childip = $active{$child};
	if ($childip ne '127.0.0.1') {
	my $childhostname = gethostbyaddr(Socket::inet_aton($childip),AF_INET);
	if ($childhostname ne '') {
	my $childlonhost = &Apache::lonnet::get_server_homeID($childhostname);
	my ($samedom,$sameinst) = &set_client_info($childlonhost);
	if ($samedom) {
	if ($connchange{'dom'}) {
	logthis('<font color="blue"> UpdateHosts killing child '
	." $child for ip $childip </font>");
	kill('INT', $child);
	}
	} elsif ($sameinst) {
	if ($connchange{'intdom'}) {
	logthis('<font color="blue"> UpdateHosts killing child '
	." $child for ip $childip </font>");
	kill('INT', $child);
	}
	} else {
	if ($connchange{'other'}) {
	logthis('<font color="blue"> UpdateHosts killing child '
	." $child for ip $childip </font>");
	kill('INT', $child);
	}
	}
	}
	}
	}
	}
ReloadApache;	ReloadApache;
&status("Finished reloading hosts.tab");	&status("Finished reloading hosts.tab");
}	}


sub checkchildren {	sub checkchildren {
&status("Checking on the children (sending signals)");	&status("Checking on the children (sending signals)");
&initnewstatus();	&initnewstatus();
Line 7055 if ($arch eq 'unknown') {	Line 7287 if ($arch eq 'unknown') {
chomp($arch);	chomp($arch);
}	}

	unless (lonssl::Read_Connect_Config(\%secureconf,\%crlchecked,\%perlvar) eq 'ok') {
	&logthis('<font color="blue">No connectionrules table. Will fallback to loncapa.conf</font>');
	}

# --------------------------------------------------------------	# --------------------------------------------------------------
# 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 7185 sub make_new_child {	Line 7421 sub make_new_child {
$ConnectionType = "manager";	$ConnectionType = "manager";
$clientname = $managers{$outsideip};	$clientname = $managers{$outsideip};
}	}
my $clientok;	my ($clientok,$clientinfoset);

if ($clientrec \|\| $ismanager) {	if ($clientrec \|\| $ismanager) {
&status("Waiting for init from $clientip $clientname");	&status("Waiting for init from $clientip $clientname");
Line 7213 sub make_new_child {	Line 7449 sub make_new_child {
# If the connection type is ssl, but I didn't get my	# If the connection type is ssl, but I didn't get my
# certificate files yet, then I'll drop back to	# certificate files yet, then I'll drop back to
# insecure (if allowed).	# insecure (if allowed).

	if ($inittype eq "ssl") {
	my $context;
	if ($clientsamedom) {
	$context = 'dom';
	if ($secureconf{'connfrom'}{'dom'} eq 'no') {
	$inittype = "";
	}
	} elsif ($clientsameinst) {
	$context = 'intdom';
	if ($secureconf{'connfrom'}{'intdom'} eq 'no') {
	$inittype = "";
	}
	} else {
	$context = 'other';
	if ($secureconf{'connfrom'}{'other'} eq 'no') {
	$inittype = "";
	}
	}
	if ($inittype eq '') {
	&logthis("<font color=\"blue\"> Domain config set "
	."to no ssl for $clientname (context: $context)"
	." -- trying insecure auth</font>");
	}
	}

if($inittype eq "ssl") {	if($inittype eq "ssl") {
my ($ca, $cert) = lonssl::CertificateFile;	my ($ca, $cert) = lonssl::CertificateFile;
my $kfile = lonssl::KeyFile;	my $kfile = lonssl::KeyFile;
Line 7246 sub make_new_child {	Line 7507 sub make_new_child {
close $client;	close $client;
}	}
} elsif ($inittype eq "ssl") {	} elsif ($inittype eq "ssl") {
my $key = SSLConnection($client);	my $key = SSLConnection($client,$clientname);
if ($key) {	if ($key) {
$clientok = 1;	$clientok = 1;
my $cipherkey = pack("H32", $key);	my $cipherkey = pack("H32", $key);
Line 7261 sub make_new_child {	Line 7522 sub make_new_child {
}	}

} else {	} else {
	$clientinfoset = &set_client_info();
my $ok = InsecureConnection($client);	my $ok = InsecureConnection($client);
if($ok) {	if($ok) {
$clientok = 1;	$clientok = 1;
Line 7273 sub make_new_child {	Line 7535 sub make_new_child {
."Attempted insecure connection disallowed </font>");	."Attempted insecure connection disallowed </font>");
close $client;	close $client;
$clientok = 0;	$clientok = 0;

}	}
}	}
} else {	} else {
Line 7282 sub make_new_child {	Line 7543 sub make_new_child {
."$clientip failed to initialize: >$remotereq< </font>");	."$clientip failed to initialize: >$remotereq< </font>");
&status('No init '.$clientip);	&status('No init '.$clientip);
}	}

} else {	} else {
&logthis(	&logthis(
"<font color='blue'>WARNING: Unknown client $clientip</font>");	"<font color='blue'>WARNING: Unknown client $clientip</font>");
Line 7300 sub make_new_child {	Line 7560 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);	unless ($clientinfoset) {
my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);	$clientinfoset = &set_client_info();
$clienthomedom = &Apache::lonnet::host_domain($clientserverhomeID);
$clientintdom = &Apache::lonnet::internet_dom($clientserverhomeID);
$clientsameinst = 0;
if ($clientintdom ne '') {
my $internet_names = &Apache::lonnet::get_internet_names($currenthostid);
if (ref($internet_names) eq 'ARRAY') {
if (grep(/^\Q$clientintdom\E$/,@{$internet_names})) {
$clientsameinst = 1;
}
}
}	}
$clientremoteok = 0;	$clientremoteok = 0;
unless ($clientsameinst) {	unless ($clientsameinst) {
Line 7367 sub make_new_child {	Line 7617 sub make_new_child {
exit;	exit;

}	}

	#
	# Used to determine if a particular client is from the same domain
	# as the current server, or from the same internet domain.
	#
	# Optional input -- the client to check for domain and internet domain.
	# If not specified, defaults to the package variable: $clientname
	#
	# If called in array context will not set package variables, but will
	# instead return an array of two values - (a) true if client is in the
	# same domain as the server, and (b) true if client is in the same internet
	# domain.
	#
	# If called in scalar context, sets package variables for current client:
	#
	# $clienthomedom - LonCAPA domain of homeID for client.
	# $clientsamedom - LonCAPA domain same for this host and client.
	# $clientintdom - LonCAPA "internet domain" for client.
	# $clientsameinst - LonCAPA "internet domain" same for this host & client.
	#
	# returns 1 to indicate package variables have been set for current client.
	#

	sub set_client_info {
	my ($lonhost) = @_;
	$lonhost \|\|= $clientname;
	my $clienthost = &Apache::lonnet::hostname($lonhost);
	my $clientserverhomeID = &Apache::lonnet::get_server_homeID($clienthost);
	my $homedom = &Apache::lonnet::host_domain($clientserverhomeID);
	my $samedom = 0;
	if ($perlvar{'lonDefDom'} eq $homedom) {
	$samedom = 1;
	}
	my $intdom = &Apache::lonnet::internet_dom($clientserverhomeID);
	my $sameinst = 0;
	if ($intdom ne '') {
	my $internet_names = &Apache::lonnet::get_internet_names($currenthostid);
	if (ref($internet_names) eq 'ARRAY') {
	if (grep(/^\Q$intdom\E$/,@{$internet_names})) {
	$sameinst = 1;
	}
	}
	}
	if (wantarray) {
	return ($samedom,$sameinst);
	} else {
	$clienthomedom = $homedom;
	$clientsamedom = $samedom;
	$clientintdom = $intdom;
	$clientsameinst = $sameinst;
	return 1;
	}
	}

#	#
# Determine if a user is an author for the indicated domain.	# Determine if a user is an author for the indicated domain.
#	#
Line 7475 sub password_filename {	Line 7779 sub password_filename {
# domain - domain of the user.	# domain - domain of the user.
# name - User's name.	# name - User's name.
# contents - New contents of the file.	# contents - New contents of the file.
	# saveold - (optional). If true save old file in a passwd.bak file.
# Returns:	# Returns:
# 0 - Failed.	# 0 - Failed.
# 1 - Success.	# 1 - Success.
#	#
sub rewrite_password_file {	sub rewrite_password_file {
my ($domain, $user, $contents) = @_;	my ($domain, $user, $contents, $saveold) = @_;

my $file = &password_filename($domain, $user);	my $file = &password_filename($domain, $user);
if (defined $file) {	if (defined $file) {
	if ($saveold) {
	my $bakfile = $file.'.bak';
	if (CopyFile($file,$bakfile)) {
	chmod(0400,$bakfile);
	&logthis("Old password saved in passwd.bak for internally authenticated user: $user:$domain");
	} else {
	&logthis("Failed to save old password in passwd.bak for internally authenticated user: $user:$domain");
	}
	}
my $pf = IO::File->new(">$file");	my $pf = IO::File->new(">$file");
if($pf) {	if($pf) {
print $pf "$contents\n";	print $pf "$contents\n";
Line 7574 sub validate_user {	Line 7888 sub validate_user {
$contentpwd = $domdefaults{'auth_arg_def'};	$contentpwd = $domdefaults{'auth_arg_def'};
}	}
}	}
}	}
if ($howpwd ne 'nouser') {	if ($howpwd ne 'nouser') {
if($howpwd eq "internal") { # Encrypted is in local password file.	if($howpwd eq "internal") { # Encrypted is in local password file.
if (length($contentpwd) == 13) {	if (length($contentpwd) == 13) {
$validated = (crypt($password,$contentpwd) eq $contentpwd);	$validated = (crypt($password,$contentpwd) eq $contentpwd);
if ($validated) {	if ($validated) {
my $ncpass = &hash_passwd($domain,$password);	my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
if (&rewrite_password_file($domain,$user,"$howpwd:$ncpass")) {	if ($domdefaults{'intauth_switch'}) {
&update_passwd_history($user,$domain,$howpwd,'conversion');	my $ncpass = &hash_passwd($domain,$password);
&logthis("Validated password hashed with bcrypt for $user:$domain");	my $saveold;
	if ($domdefaults{'intauth_switch'} == 2) {
	$saveold = 1;
	}
	if (&rewrite_password_file($domain,$user,"$howpwd:$ncpass",$saveold)) {
	&update_passwd_history($user,$domain,$howpwd,'conversion');
	&logthis("Validated password hashed with bcrypt for $user:$domain");
	}
}	}
}	}
} else {	} else {
$validated = &check_internal_passwd($password,$contentpwd,$domain);	$validated = &check_internal_passwd($password,$contentpwd,$domain,$user);
}	}
}	}
elsif ($howpwd eq "unix") { # User is a normal unix user.	elsif ($howpwd eq "unix") { # User is a normal unix user.
Line 7657 sub validate_user {	Line 7978 sub validate_user {
}	}

sub check_internal_passwd {	sub check_internal_passwd {
my ($plainpass,$stored,$domain) = @_;	my ($plainpass,$stored,$domain,$user) = @_;
my (undef,$method,@rest) = split(/!/,$stored);	my (undef,$method,@rest) = split(/!/,$stored);
if ($method eq "bcrypt") {	if ($method eq 'bcrypt') {
my $result = &hash_passwd($domain,$plainpass,@rest);	my $result = &hash_passwd($domain,$plainpass,@rest);
if ($result ne $stored) {	if ($result ne $stored) {
return 0;	return 0;
}	}
# Upgrade to a larger number of rounds if necessary	my %domdefaults = &Apache::lonnet::get_domain_defaults($domain);
my $defaultcost;	if ($domdefaults{'intauth_check'}) {
my %domconfig =	# Upgrade to a larger number of rounds if necessary
&Apache::lonnet::get_dom('configuration',['password'],$domain);	my $defaultcost = $domdefaults{'intauth_cost'};
if (ref($domconfig{'password'}) eq 'HASH') {	if (($defaultcost eq '') \|\| ($defaultcost =~ /D/)) {
$defaultcost = $domconfig{'password'}{'cost'};	$defaultcost = 10;
}	}
if (($defaultcost eq '') \|\| ($defaultcost =~ /D/)) {	if (int($rest[0])<int($defaultcost)) {
$defaultcost = 10;	if ($domdefaults{'intauth_check'} == 1) {
	my $ncpass = &hash_passwd($domain,$plainpass);
	if (&rewrite_password_file($domain,$user,"internal:$ncpass")) {
	&update_passwd_history($user,$domain,'internal','update cost');
	&logthis("Validated password hashed with bcrypt for $user:$domain");
	}
	return 1;
	} elsif ($domdefaults{'intauth_check'} == 2) {
	return 0;
	}
	}
	} else {
	return 1;
}	}
return 1 unless($rest[0]<$defaultcost);
}	}
return 0;	return 0;
}	}
Line 8050 sub make_passwd_file {	Line 8382 sub make_passwd_file {
$result = "pass_file_failed_error";	$result = "pass_file_failed_error";
}	}
}	}
	} elsif ($umode eq 'lti') {
	my $pf = IO::File->new(">$passfilename");
	if($pf) {
	print $pf "lti:\n";
	&update_passwd_history($uname,$udom,$umode,$action);
	} else {
	$result = "pass_file_failed_error";
	}
} else {	} else {
$result="auth_mode_error";	$result="auth_mode_error";
}	}
Line 8102 sub get_usersession_config {	Line 8442 sub get_usersession_config {
return;	return;
}	}

	sub get_usersearch_config {
	my ($dom,$name) = @_;
	my ($usersearchconf,$cached)=&Apache::lonnet::is_cached_new($name,$dom);
	if (defined($cached)) {
	return $usersearchconf;
	} else {
	my %domconfig = &Apache::lonnet::get_dom('configuration',['directorysrch'],$dom);
	&Apache::lonnet::do_cache_new($name,$dom,$domconfig{'directorysrch'},600);
	return $domconfig{'directorysrch'};
	}
	return;
	}

sub get_prohibited {	sub get_prohibited {
my ($dom) = @_;	my ($dom) = @_;
my $name = 'trust';	my $name = 'trust';
Line 8462 IO::File	Line 8815 IO::File
Apache::File	Apache::File
POSIX	POSIX
Crypt::IDEA	Crypt::IDEA
LWP::UserAgent()
GDBM_File	GDBM_File
Authen::Krb4	Authen::Krb4
Authen::Krb5	Authen::Krb5

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

Removed from v.1.531
changed lines
	Added in v.1.546