loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.526 and 1.539

version 1.526, 2016/09/20 23:48:07	version 1.539, 2017/06/06 19:32:23
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 $dist;	my $dist;

#	#
Line 223 my %trust = (	Line 229 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 266 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 267 my %trust = (	Line 285 my %trust = (
restore => {remote => 1, enroll => 1, reqcrs => 1,},	restore => {remote => 1, enroll => 1, reqcrs => 1,},
rolesdel => {remote => 1, enroll => 1, domroles => 1, coaurem => 1},	rolesdel => {remote => 1, enroll => 1, domroles => 1, coaurem => 1},
rolesput => {remote => 1, enroll => 1, domroles => 1, coaurem => 1},	rolesput => {remote => 1, enroll => 1, domroles => 1, coaurem => 1},
serverdistarch => {manageronly => 1},	servercerts => {institutiononly => 1},
	serverdistarch => {anywhere => 1},
serverhomeID => {anywhere => 1},	serverhomeID => {anywhere => 1},
serverloncaparev => {anywhere => 1},	serverloncaparev => {anywhere => 1},
servertimezone => {remote => 1, enroll => 1},	servertimezone => {remote => 1, enroll => 1},
Line 444 sub InsecureConnection {	Line 463 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 1567 sub du2_handler {	Line 1601 sub du2_handler {
# selected directory the filename followed by the full output of	# selected directory the filename followed by the full output of
# the stat function is returned. The returned info for each	# the stat function is returned. The returned info for each
# file are separated by ':'. The stat fields are separated by &'s.	# file are separated by ':'. The stat fields are separated by &'s.
	#
	# If the requested path contains /../ or is:
	#
	# 1. for a directory, and the path does not begin with one of:
	# (a) /home/httpd/html/res/<domain>
	# (b) /home/httpd/html/userfiles/
	# (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
	# or is:
	#
	# 2. for a file, and the path (after prepending) does not begin with one of:
	# (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".
	#
# Parameters:	# Parameters:
# $cmd - The command that dispatched us (ls).	# $cmd - The command that dispatched us (ls).
# $ulsdir - The directory path to list... I'm not sure what this	# $ulsdir - The directory path to list... I'm not sure what this
Line 1588 sub ls_handler {	Line 1638 sub ls_handler {
my $rights;	my $rights;
my $ulsout='';	my $ulsout='';
my $ulsfn;	my $ulsfn;
	if ($ulsdir =~m{/\.\./}) {
	&Failure($client,"refused\n",$userinput);
	return 1;
	}
if (-e $ulsdir) {	if (-e $ulsdir) {
if(-d $ulsdir) {	if(-d $ulsdir) {
	unless (($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain\|userfiles/)}) \|\|
	($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/userfiles})) {
	&Failure($client,"refused\n",$userinput);
	return 1;
	}
if (opendir(LSDIR,$ulsdir)) {	if (opendir(LSDIR,$ulsdir)) {
while ($ulsfn=readdir(LSDIR)) {	while ($ulsfn=readdir(LSDIR)) {
undef($obs);	undef($obs);
Line 1613 sub ls_handler {	Line 1672 sub ls_handler {
closedir(LSDIR);	closedir(LSDIR);
}	}
} else {	} else {
	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);
	return 1;
	}
my @ulsstats=stat($ulsdir);	my @ulsstats=stat($ulsdir);
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';	$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
}	}
Line 1637 sub ls_handler {	Line 1701 sub ls_handler {
# selected directory the filename followed by the full output of	# selected directory the filename followed by the full output of
# the stat function is returned. The returned info for each	# the stat function is returned. The returned info for each
# file are separated by ':'. The stat fields are separated by &'s.	# file are separated by ':'. The stat fields are separated by &'s.
	#
	# If the requested path contains /../ or is:
	#
	# 1. for a directory, and the path does not begin with one of:
	# (a) /home/httpd/html/res/<domain>
	# (b) /home/httpd/html/userfiles/
	# (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
	# or is:
	#
	# 2. for a file, and the path (after prepending) does not begin with one of:
	# (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".
	#
# Parameters:	# Parameters:
# $cmd - The command that dispatched us (ls).	# $cmd - The command that dispatched us (ls).
# $ulsdir - The directory path to list... I'm not sure what this	# $ulsdir - The directory path to list... I'm not sure what this
Line 1657 sub ls2_handler {	Line 1737 sub ls2_handler {
my $rights;	my $rights;
my $ulsout='';	my $ulsout='';
my $ulsfn;	my $ulsfn;
	if ($ulsdir =~m{/\.\./}) {
	&Failure($client,"refused\n",$userinput);
	return 1;
	}
if (-e $ulsdir) {	if (-e $ulsdir) {
if(-d $ulsdir) {	if(-d $ulsdir) {
	unless (($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain\|userfiles/)}) \|\|
	($ulsdir =~ m{^/home/httpd/lonUsers/$LONCAPA::match_domain(?:/[\w\-.@]){3}/$LONCAPA::match_name/userfiles})) {
	&Failure($client,"refused\n","$userinput");
	return 1;
	}
if (opendir(LSDIR,$ulsdir)) {	if (opendir(LSDIR,$ulsdir)) {
while ($ulsfn=readdir(LSDIR)) {	while ($ulsfn=readdir(LSDIR)) {
undef($obs);	undef($obs);
Line 1683 sub ls2_handler {	Line 1772 sub ls2_handler {
closedir(LSDIR);	closedir(LSDIR);
}	}
} else {	} else {
	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);
	return 1;
	}
my @ulsstats=stat($ulsdir);	my @ulsstats=stat($ulsdir);
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';	$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
}	}
Line 1699 sub ls2_handler {	Line 1793 sub ls2_handler {
# selected directory the filename followed by the full output of	# selected directory the filename followed by the full output of
# the stat function is returned. The returned info for each	# the stat function is returned. The returned info for each
# file are separated by ':'. The stat fields are separated by &'s.	# file are separated by ':'. The stat fields are separated by &'s.
	#
	# If the requested path (after prepending) contains /../ or is:
	#
	# 1. for a directory, and the path does not begin with one of:
	# (a) /home/httpd/html/res/<domain>
	# (b) /home/httpd/html/userfiles/
	# (c) /home/httpd/lonUsers/<domain>/<1>/<2>/<3>/<username>/userfiles
	# (d) /home/httpd/html/priv/<domain> and client is the homeserver
	#
	# or is:
	#
	# 2. for a file, and the path (after prepending) does not begin with one of:
	# (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".
	#
# Parameters:	# Parameters:
# $cmd - The command that dispatched us (ls).	# $cmd - The command that dispatched us (ls).
# $tail - The tail of the request that invoked us.	# $tail - The tail of the request that invoked us.
Line 1738 sub ls3_handler {	Line 1851 sub ls3_handler {
}	}

my $dir_root = $perlvar{'lonDocRoot'};	my $dir_root = $perlvar{'lonDocRoot'};
if ($getpropath) {	if (($getpropath) \|\| ($getuserdir)) {
if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {	if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
$dir_root = &propath($udom,$uname);	$dir_root = &propath($udom,$uname);
$dir_root =~ s/\/$//;	$dir_root =~ s/\/$//;
} else {	} else {
&Failure($client,"refused\n","$cmd:$tail");	&Failure($client,"refused\n",$userinput);
return 1;
}
} elsif ($getuserdir) {
if (($uname =~ /^$LONCAPA::match_name$/) && ($udom =~ /^$LONCAPA::match_domain$/)) {
my $subdir=$uname.'__';
$subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
$dir_root = $Apache::lonnet::perlvar{'lonUsersDir'}
."/$udom/$subdir/$uname";
} else {
&Failure($client,"refused\n","$cmd:$tail");
return 1;	return 1;
}	}
} elsif ($alternate_root ne '') {	} elsif ($alternate_root ne '') {
Line 1766 sub ls3_handler {	Line 1869 sub ls3_handler {
$ulsdir = $dir_root.'/'.$ulsdir;	$ulsdir = $dir_root.'/'.$ulsdir;
}	}
}	}
	if ($ulsdir =~m{/\.\./}) {
	&Failure($client,"refused\n",$userinput);
	return 1;
	}
	my $islocal;
	my @machine_ids = &Apache::lonnet::current_machine_ids();
	if (grep(/^\Q$clientname\E$/,@machine_ids)) {
	$islocal = 1;
	}
my $obs;	my $obs;
my $rights;	my $rights;
my $ulsout='';	my $ulsout='';
my $ulsfn;	my $ulsfn;
if (-e $ulsdir) {	if (-e $ulsdir) {
if(-d $ulsdir) {	if(-d $ulsdir) {
	unless (($getpropath) \|\| ($getuserdir) \|\|
	($ulsdir =~ m{^/home/httpd/html/(res/$LONCAPA::match_domain\|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))) {
	&Failure($client,"refused\n",$userinput);
	return 1;
	}
if (opendir(LSDIR,$ulsdir)) {	if (opendir(LSDIR,$ulsdir)) {
while ($ulsfn=readdir(LSDIR)) {	while ($ulsfn=readdir(LSDIR)) {
undef($obs);	undef($obs);
Line 1796 sub ls3_handler {	Line 1915 sub ls3_handler {
closedir(LSDIR);	closedir(LSDIR);
}	}
} else {	} else {
	unless (($getpropath) \|\| ($getuserdir) \|\|
	($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);
	return 1;
	}
my @ulsstats=stat($ulsdir);	my @ulsstats=stat($ulsdir);
$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';	$ulsout.=$ulsfn.'&'.join('&',@ulsstats).':';
}	}
Line 1819 sub read_lonnet_global {	Line 1946 sub read_lonnet_global {
);	);
my %limit_to = (	my %limit_to = (
perlvar => {	perlvar => {
lonOtherAuthen => 1,	lonOtherAuthen => 1,
lonBalancer => 1,	lonBalancer => 1,
lonVersion => 1,	lonVersion => 1,
lonSysEMail => 1,	lonAdmEMail => 1,
lonHostID => 1,	lonSupportEMail => 1,
lonRole => 1,	lonSysEMail => 1,
lonDefDomain => 1,	lonHostID => 1,
lonLoadLim => 1,	lonRole => 1,
lonUserLoadLim => 1,	lonDefDomain => 1,
	lonLoadLim => 1,
	lonUserLoadLim => 1,
}	}
);	);
if (ref($requested) eq 'HASH') {	if (ref($requested) eq 'HASH') {
Line 2218 sub hash_passwd {	Line 2347 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 2478 sub update_resource_handler {	Line 2603 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	# FIXME: we should probably clean up here instead of just whine
unlink($transname);	unlink($transname);
Line 2494 sub update_resource_handler {	Line 2614 sub update_resource_handler {
&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 2573 sub fetch_user_file_handler {	Line 2688 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 3281 sub get_profile_entry {	Line 3392 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 3853 sub retrieve_chat_handler {	Line 3965 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 3867 sub retrieve_chat_handler {	Line 3979 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 4734 sub get_domain_handler {	Line 4876 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 4747 sub get_domain_handler {	Line 4923 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 5659 sub auto_export_grades_handler {	Line 5847 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 6410 sub process_request {	Line 6598 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 6451 sub process_request {	Line 6651 sub process_request {
}	}
}	}
}	}
	$command = $realcommand;
}	}

if($ok) {	if($ok) {
Line 6719 sub UpdateHosts {	Line 6920 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 6728 sub UpdateHosts {	Line 6930 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,\%perlvar) eq 'ok') {
	logthis('<font color="blue"> Reloaded SSL connection rules </font>');
	} else {
	logthis('<font color="yellow"> Failed to reload SSL connection rules </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 6971 if ($arch eq 'unknown') {	Line 7220 if ($arch eq 'unknown') {
chomp($arch);	chomp($arch);
}	}

	unless (lonssl::Read_Connect_Config(\%secureconf,\%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 7101 sub make_new_child {	Line 7354 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 7129 sub make_new_child {	Line 7382 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 7162 sub make_new_child {	Line 7440 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 7177 sub make_new_child {	Line 7455 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 7189 sub make_new_child {	Line 7468 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 7198 sub make_new_child {	Line 7476 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 7216 sub make_new_child {	Line 7493 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 7283 sub make_new_child {	Line 7550 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 7391 sub password_filename {	Line 7712 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 7490 sub validate_user {	Line 7821 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 7573 sub validate_user {	Line 7911 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 8018 sub get_usersession_config {	Line 8367 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 8378 IO::File	Line 8740 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.526
changed lines
	Added in v.1.539