loncom/lond - diff

Return to lond CVS log

Up to [LON-CAPA] / loncom

Diff for /loncom/lond between versions 1.170 and 1.204

version 1.170, 2004/01/07 21:13:52	version 1.204, 2004/06/29 15:31:32
Line 45 use Authen::Krb4;	Line 45 use Authen::Krb4;
use Authen::Krb5;	use Authen::Krb5;
use lib '/home/httpd/lib/perl/';	use lib '/home/httpd/lib/perl/';
use localauth;	use localauth;
	use localenroll;
use File::Copy;	use File::Copy;
use LONCAPA::ConfigFileEdit;	use LONCAPA::ConfigFileEdit;
	use LONCAPA::lonlocal;
	use LONCAPA::lonssl;

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

Line 59 my $currenthostid;	Line 62 my $currenthostid;
my $currentdomainid;	my $currentdomainid;

my $client;	my $client;
my $clientip;	my $clientip; # IP address of client.
my $clientname;	my $clientdns; # DNS name of client.
	my $clientname; # LonCAPA name of client.

my $server;	my $server;
my $thisserver;	my $thisserver; # DNS of us.

	my $keymode;

#	#
# Connection type is:	# Connection type is:
Line 74 my $thisserver;	Line 80 my $thisserver;

my $ConnectionType;	my $ConnectionType;

my %hostid;	my %hostid; # ID's for hosts in cluster by ip.
my %hostdom;	my %hostdom; # LonCAPA domain for hosts in cluster.
my %hostip;	my %hostip; # IPs for hosts in cluster.
	my %hostdns; # ID's of hosts looked up by DNS name.

my %managers; # Ip -> manager names	my %managers; # Ip -> manager names

Line 120 my @adderrors = ("ok",	Line 127 my @adderrors = ("ok",
"lcuseradd Password mismatch");	"lcuseradd Password mismatch");


	#------------------------------------------------------------------------
	#
	# LocalConnection
	# Completes the formation of a locally authenticated connection.
	# This function will ensure that the 'remote' client is really the
	# local host. If not, the connection is closed, and the function fails.
	# If so, initcmd is parsed for the name of a file containing the
	# IDEA session key. The fie is opened, read, deleted and the session
	# key returned to the caller.
	#
	# Parameters:
	# $Socket - Socket open on client.
	# $initcmd - The full text of the init command.
	#
	# Implicit inputs:
	# $clientdns - The DNS name of the remote client.
	# $thisserver - Our DNS name.
	#
	# Returns:
	# IDEA session key on success.
	# undef on failure.
	#
	sub LocalConnection {
	my ($Socket, $initcmd) = @_;
	Debug("Attempting local connection: $initcmd client: $clientdns me: $thisserver");
	if($clientdns ne $thisserver) {
	&logthis('<font color="red"> LocalConnection rejecting non local: '
	."$clientdns ne $thisserver </font>");
	close $Socket;
	return undef;
	}
	else {
	chomp($initcmd); # Get rid of \n in filename.
	my ($init, $type, $name) = split(/:/, $initcmd);
	Debug(" Init command: $init $type $name ");

	# Require that $init = init, and $type = local: Otherwise
	# the caller is insane:

	if(($init ne "init") && ($type ne "local")) {
	&logthis('<font color = "red"> LocalConnection: caller is insane! '
	."init = $init, and type = $type </font>");
	close($Socket);;
	return undef;

	}
	# Now get the key filename:

	my $IDEAKey = lonlocal::ReadKeyFile($name);
	return $IDEAKey;
	}
	}
	#------------------------------------------------------------------------------
	#
	# SSLConnection
	# Completes the formation of an ssh authenticated connection. The
	# socket is promoted to an ssl socket. If this promotion and the associated
	# certificate exchange are successful, the IDEA key is generated and sent
	# to the remote peer via the SSL tunnel. The IDEA key is also returned to
	# the caller after the SSL tunnel is torn down.
	#
	# Parameters:
	# Name Type Purpose
	# $Socket IO::Socket::INET Plaintext socket.
	#
	# Returns:
	# IDEA key on success.
	# undef on failure.
	#
	sub SSLConnection {
	my $Socket = shift;

	Debug("SSLConnection: ");
	my $KeyFile = lonssl::KeyFile();
	if(!$KeyFile) {
	my $err = lonssl::LastError();
	&logthis("<font color=\"red\"> CRITICAL"
	."Can't get key file $err </font>");
	return undef;
	}
	my ($CACertificate,
	$Certificate) = lonssl::CertificateFile();


	# If any of the key, certificate or certificate authority
	# certificate filenames are not defined, this can't work.

	if((!$Certificate) \|\| (!$CACertificate)) {
	my $err = lonssl::LastError();
	&logthis("<font color=\"red\"> CRITICAL"
	."Can't get certificates: $err </font>");

	return undef;
	}
	Debug("Key: $KeyFile CA: $CACertificate Cert: $Certificate");

	# Indicate to our peer that we can procede with
	# a transition to ssl authentication:

	print $Socket "ok:ssl\n";

	Debug("Approving promotion -> ssl");
	# And do so:

	my $SSLSocket = lonssl::PromoteServerSocket($Socket,
	$CACertificate,
	$Certificate,
	$KeyFile);
	if(! ($SSLSocket) ) { # SSL socket promotion failed.
	my $err = lonssl::LastError();
	&logthis("<font color=\"red\"> CRITICAL "
	."SSL Socket promotion failed: $err </font>");
	return undef;
	}
	Debug("SSL Promotion successful");

	#
	# The only thing we'll use the socket for is to send the IDEA key
	# to the peer:

	my $Key = lonlocal::CreateCipherKey();
	print $SSLSocket "$Key\n";

	lonssl::Close($SSLSocket);

	Debug("Key exchange complete: $Key");

	return $Key;
	}
	#
	# InsecureConnection:
	# If insecure connections are allowd,
	# exchange a challenge with the client to 'validate' the
	# client (not really, but that's the protocol):
	# We produce a challenge string that's sent to the client.
	# The client must then echo the challenge verbatim to us.
	#
	# Parameter:
	# Socket - Socket open on the client.
	# Returns:
	# 1 - success.
	# 0 - failure (e.g.mismatch or insecure not allowed).
	#
	sub InsecureConnection {
	my $Socket = shift;

	# Don't even start if insecure connections are not allowed.

	if(! $perlvar{londAllowInsecure}) { # Insecure connections not allowed.
	return 0;
	}

	# Fabricate a challenge string and send it..

	my $challenge = "$$".time; # pid + time.
	print $Socket "$challenge\n";
	&status("Waiting for challenge reply");

	my $answer = <$Socket>;
	$answer =~s/\W//g;
	if($challenge eq $answer) {
	return 1;
	}
	else {
	logthis("<font color='blue'>WARNING client did not respond to challenge</font>");
	&status("No challenge reqply");
	return 0;
	}


	}

#	#
# GetCertificate: Given a transaction that requires a certificate,	# GetCertificate: Given a transaction that requires a certificate,
# this function will extract the certificate from the transaction	# this function will extract the certificate from the transaction
Line 175 sub ReadManagerTable {	Line 354 sub ReadManagerTable {
while(my $host = <MANAGERS>) {	while(my $host = <MANAGERS>) {
chomp($host);	chomp($host);
if ($host =~ "^#") { # Comment line.	if ($host =~ "^#") { # Comment line.
logthis('<font color="green"> Skipping line: '. "$host</font>\n");
next;	next;
}	}
if (!defined $hostip{$host}) { # This is a non cluster member	if (!defined $hostip{$host}) { # This is a non cluster member
Line 225 sub ValidManager {	Line 403 sub ValidManager {
# 1 - Success.	# 1 - Success.
#	#
sub CopyFile {	sub CopyFile {
my $oldfile = shift;
my $newfile = shift;	my ($oldfile, $newfile) = @_;

# The file must exist:	# The file must exist:

Line 326 sub AdjustHostContents {	Line 504 sub AdjustHostContents {
# 0 - failure and $! has an errno.	# 0 - failure and $! has an errno.
#	#
sub InstallFile {	sub InstallFile {
my $Filename = shift;
my $Contents = shift;	my ($Filename, $Contents) = @_;
my $TempFile = $Filename.".tmp";	my $TempFile = $Filename.".tmp";

# Open the file for write:	# Open the file for write:
Line 350 sub InstallFile {	Line 528 sub InstallFile {

return 1;	return 1;
}	}


#	#
# ConfigFileFromSelector: converts a configuration file selector	# ConfigFileFromSelector: converts a configuration file selector
# (one of host or domain at this point) into a	# (one of host or domain at this point) into a
Line 564 sub isValidEditCommand {	Line 744 sub isValidEditCommand {
# file being edited.	# file being edited.
#	#
sub ApplyEdit {	sub ApplyEdit {
my $directive = shift;
my $editor = shift;	my ($directive, $editor) = @_;

# Break the directive down into its command and its parameters	# Break the directive down into its command and its parameters
# (at most two at this point. The meaning of the parameters, if in fact	# (at most two at this point. The meaning of the parameters, if in fact
Line 649 sub AdjustOurHost {	Line 829 sub AdjustOurHost {
# editor - Editor containing the file.	# editor - Editor containing the file.
#	#
sub ReplaceConfigFile {	sub ReplaceConfigFile {
my $filename = shift;
my $editor = shift;	my ($filename, $editor) = @_;

CopyFile ($filename, $filename.".old");	CopyFile ($filename, $filename.".old");

Line 749 sub catchexception {	Line 929 sub catchexception {
$SIG{'QUIT'}='DEFAULT';	$SIG{'QUIT'}='DEFAULT';
$SIG{__DIE__}='DEFAULT';	$SIG{__DIE__}='DEFAULT';
&status("Catching exception");	&status("Catching exception");
&logthis("<font color=red>CRITICAL: "	&logthis("<font color='red'>CRITICAL: "
."ABNORMAL EXIT. Child $$ for server $thisserver died through "	."ABNORMAL EXIT. Child $$ for server $thisserver died through "
."a crash with this error msg->[$error]</font>");	."a crash with this error msg->[$error]</font>");
&logthis('Famous last words: '.$status.' - '.$lastlog);	&logthis('Famous last words: '.$status.' - '.$lastlog);
Line 760 sub catchexception {	Line 940 sub catchexception {

sub timeout {	sub timeout {
&status("Handling Timeout");	&status("Handling Timeout");
&logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");	&logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
&catchexception('Timeout');	&catchexception('Timeout');
}	}
# -------------------------------- Set signal handlers to record abnormal exits	# -------------------------------- Set signal handlers to record abnormal exits
Line 812 $server = IO::Socket::INET->new(LocalPor	Line 992 $server = IO::Socket::INET->new(LocalPor
# global variables	# global variables

my %children = (); # keys are current child process IDs	my %children = (); # keys are current child process IDs
my $children = 0; # current number of children

sub REAPER { # takes care of dead children	sub REAPER { # takes care of dead children
$SIG{CHLD} = \&REAPER;	$SIG{CHLD} = \&REAPER;
&status("Handling child death");	&status("Handling child death");
my $pid = wait;	my $pid;
if (defined($children{$pid})) {	do {
&logthis("Child $pid died");	$pid = waitpid(-1,&WNOHANG());
$children --;	if (defined($children{$pid})) {
delete $children{$pid};	&logthis("Child $pid died");
} else {	delete($children{$pid});
&logthis("Unknown Child $pid died");	} elsif ($pid > 0) {
	&logthis("Unknown Child $pid died");
	}
	} while ( $pid > 0 );
	foreach my $child (keys(%children)) {
	$pid = waitpid($child,&WNOHANG());
	if ($pid > 0) {
	&logthis("Child $child - $pid looks like we missed it's death");
	delete($children{$pid});
	}
}	}
&status("Finished Handling child death");	&status("Finished Handling child death");
}	}
Line 835 sub HUNTSMAN { # si	Line 1023 sub HUNTSMAN { # si
&logthis("Free socket: ".shutdown($server,2)); # free up socket	&logthis("Free socket: ".shutdown($server,2)); # free up socket
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
unlink("$execdir/logs/lond.pid");	unlink("$execdir/logs/lond.pid");
&logthis("<font color=red>CRITICAL: Shutting down</font>");	&logthis("<font color='red'>CRITICAL: Shutting down</font>");
&status("Done killing children");	&status("Done killing children");
exit; # clean up with dignity	exit; # clean up with dignity
}	}
Line 845 sub HUPSMAN { # sig	Line 1033 sub HUPSMAN { # sig
&status("Killing children for restart (HUP)");	&status("Killing children for restart (HUP)");
kill 'INT' => keys %children;	kill 'INT' => keys %children;
&logthis("Free socket: ".shutdown($server,2)); # free up socket	&logthis("Free socket: ".shutdown($server,2)); # free up socket
&logthis("<font color=red>CRITICAL: Restarting</font>");	&logthis("<font color='red'>CRITICAL: Restarting</font>");
my $execdir=$perlvar{'lonDaemons'};	my $execdir=$perlvar{'lonDaemons'};
unlink("$execdir/logs/lond.pid");	unlink("$execdir/logs/lond.pid");
&status("Restarting self (HUP)");	&status("Restarting self (HUP)");
Line 855 sub HUPSMAN { # sig	Line 1043 sub HUPSMAN { # sig
#	#
# Kill off hashes that describe the host table prior to re-reading it.	# Kill off hashes that describe the host table prior to re-reading it.
# Hashes affected are:	# Hashes affected are:
# %hostid, %hostdom %hostip	# %hostid, %hostdom %hostip %hostdns.
#	#
sub KillHostHashes {	sub KillHostHashes {
foreach my $key (keys %hostid) {	foreach my $key (keys %hostid) {
Line 867 sub KillHostHashes {	Line 1055 sub KillHostHashes {
foreach my $key (keys %hostip) {	foreach my $key (keys %hostip) {
delete $hostip{$key};	delete $hostip{$key};
}	}
	foreach my $key (keys %hostdns) {
	delete $hostdns{$key};
	}
}	}
#	#
# Read in the host table from file and distribute it into the various hashes:	# Read in the host table from file and distribute it into the various hashes:
Line 877 sub KillHostHashes {	Line 1068 sub KillHostHashes {
sub ReadHostTable {	sub ReadHostTable {

open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") \|\| die "Can't read host file";	open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") \|\| die "Can't read host file";
	my $myloncapaname = $perlvar{'lonHostID'};
	Debug("My loncapa name is : $myloncapaname");
while (my $configline=<CONFIG>) {	while (my $configline=<CONFIG>) {
my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);	if (!($configline =~ /^\s*\#/)) {
chomp($ip); $ip=~s/\D+$//;	my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
$hostid{$ip}=$id;	chomp($ip); $ip=~s/\D+$//;
$hostdom{$id}=$domain;	$hostid{$ip}=$id; # LonCAPA name of host by IP.
$hostip{$id}=$ip;	$hostdom{$id}=$domain; # LonCAPA domain name of host.
if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }	$hostip{$id}=$ip; # IP address of host.
	$hostdns{$name} = $id; # LonCAPA name of host by DNS.

	if ($id eq $perlvar{'lonHostID'}) {
	Debug("Found me in the host table: $name");
	$thisserver=$name;
	}
	}
}	}
close(CONFIG);	close(CONFIG);
}	}
Line 1005 sub Debug {	Line 1204 sub Debug {
# request - Original request from client.	# request - Original request from client.
#	#
sub Reply {	sub Reply {
my $fd = shift;
my $reply = shift;	my ($fd, $reply, $request) = @_;
my $request = shift;

print $fd $reply;	print $fd $reply;
Debug("Request was $request Reply was $reply");	Debug("Request was $request Reply was $reply");
Line 1020 sub logstatus {	Line 1218 sub logstatus {
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");
print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n";	print $fh $$."\t".$clientname."\t".$currenthostid."\t"
	.$status."\t".$lastlog."\t $keymode\n";
$fh->close();	$fh->close();
}	}
&status("Finished londstatus.txt");	&status("Finished londstatus.txt");
{	{
my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");	my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt");
print $fh $status."\n".$lastlog."\n".time;	print $fh $status."\n".$lastlog."\n".time."\n$keymode";
$fh->close();	$fh->close();
}	}
&status("Finished logging");	&status("Finished logging");
Line 1085 sub reconlonc {	Line 1284 sub reconlonc {
kill USR1 => $loncpid;	kill USR1 => $loncpid;
} else {	} else {
&logthis(	&logthis(
"<font color=red>CRITICAL: "	"<font color='red'>CRITICAL: "
."lonc at pid $loncpid not responding, giving up</font>");	."lonc at pid $loncpid not responding, giving up</font>");
}	}
} else {	} else {
&logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');	&logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');
}	}
}	}

Line 1193 my $execdir=$perlvar{'lonDaemons'};	Line 1392 my $execdir=$perlvar{'lonDaemons'};
open (PIDSAVE,">$execdir/logs/lond.pid");	open (PIDSAVE,">$execdir/logs/lond.pid");
print PIDSAVE "$$\n";	print PIDSAVE "$$\n";
close(PIDSAVE);	close(PIDSAVE);
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");	&logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
&status('Starting');	&status('Starting');


Line 1248 sub make_new_child {	Line 1447 sub make_new_child {
# the pid hash.	# the pid hash.
#	#
my $caller = getpeername($client);	my $caller = getpeername($client);
my ($port,$iaddr)=unpack_sockaddr_in($caller);	my ($port,$iaddr);
$clientip=inet_ntoa($iaddr);	if (defined($caller) && length($caller) > 0) {
	($port,$iaddr)=unpack_sockaddr_in($caller);
	} else {
	&logthis("Unable to determine who caller was, getpeername returned nothing");
	}
	if (defined($iaddr)) {
	$clientip = inet_ntoa($iaddr);
	Debug("Connected with $clientip");
	$clientdns = gethostbyaddr($iaddr, AF_INET);
	Debug("Connected with $clientdns by name");
	} else {
	&logthis("Unable to determine clientip");
	$clientip='Unavailable';
	}

if ($pid) {	if ($pid) {
# Parent records the child's birth and returns.	# Parent records the child's birth and returns.
sigprocmask(SIG_UNBLOCK, $sigset)	sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";	or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = $clientip;	$children{$pid} = $clientip;
$children++;
&status('Started child '.$pid);	&status('Started child '.$pid);
return;	return;
} else {	} else {
Line 1282 sub make_new_child {	Line 1493 sub make_new_child {
# =============================================================================	# =============================================================================
# do something with the connection	# do something with the connection
# -----------------------------------------------------------------------------	# -----------------------------------------------------------------------------
# see if we know client and check for spoof IP by challenge	# see if we know client and 'check' for spoof IP by ineffective challenge

ReadManagerTable; # May also be a manager!!	ReadManagerTable; # May also be a manager!!

Line 1300 sub make_new_child {	Line 1511 sub make_new_child {
$clientname = $managers{$clientip};	$clientname = $managers{$clientip};
}	}
my $clientok;	my $clientok;

if ($clientrec \|\| $ismanager) {	if ($clientrec \|\| $ismanager) {
&status("Waiting for init from $clientip $clientname");	&status("Waiting for init from $clientip $clientname");
&logthis('<font color="yellow">INFO: Connection, '.	&logthis('<font color="yellow">INFO: Connection, '.
Line 1307 sub make_new_child {	Line 1519 sub make_new_child {
" ($clientname) connection type = $ConnectionType </font>" );	" ($clientname) connection type = $ConnectionType </font>" );
&status("Connecting $clientip ($clientname))");	&status("Connecting $clientip ($clientname))");
my $remotereq=<$client>;	my $remotereq=<$client>;
$remotereq=~s/[^\w:]//g;	chomp($remotereq);
	Debug("Got init: $remotereq");
	my $inikeyword = split(/:/, $remotereq);
if ($remotereq =~ /^init/) {	if ($remotereq =~ /^init/) {
&sethost("sethost:$perlvar{'lonHostID'}");	&sethost("sethost:$perlvar{'lonHostID'}");
my $challenge="$$".time;	#
print $client "$challenge\n";	# If the remote is attempting a local init... give that a try:
&status(	#
"Waiting for challenge reply from $clientip ($clientname)");	my ($i, $inittype) = split(/:/, $remotereq);
$remotereq=<$client>;
$remotereq=~s/\W//g;	# If the connection type is ssl, but I didn't get my
if ($challenge eq $remotereq) {	# certificate files yet, then I'll drop back to
$clientok=1;	# insecure (if allowed).
print $client "ok\n";
	if($inittype eq "ssl") {
	my ($ca, $cert) = lonssl::CertificateFile;
	my $kfile = lonssl::KeyFile;
	if((!$ca) \|\|
	(!$cert) \|\|
	(!$kfile)) {
	$inittype = ""; # This forces insecure attempt.
	&logthis("<font color=\"blue\"> Certificates not "
	."installed -- trying insecure auth</font>");
	}
	else { # SSL certificates are in place so
	} # Leave the inittype alone.
	}

	if($inittype eq "local") {
	my $key = LocalConnection($client, $remotereq);
	if($key) {
	Debug("Got local key $key");
	$clientok = 1;
	my $cipherkey = pack("H32", $key);
	$cipher = new IDEA($cipherkey);
	print $client "ok:local\n";
	&logthis('<font color="green"'
	. "Successful local authentication </font>");
	$keymode = "local"
	} else {
	Debug("Failed to get local key");
	$clientok = 0;
	shutdown($client, 3);
	close $client;
	}
	} elsif ($inittype eq "ssl") {
	my $key = SSLConnection($client);
	if ($key) {
	$clientok = 1;
	my $cipherkey = pack("H32", $key);
	$cipher = new IDEA($cipherkey);
	&logthis('<font color="green">'
	."Successfull ssl authentication with $clientname </font>");
	$keymode = "ssl";

	} else {
	$clientok = 0;
	close $client;
	}

} else {	} else {
&logthis(	my $ok = InsecureConnection($client);
"<font color=blue>WARNING: $clientip did not reply challenge</font>");	if($ok) {
&status('No challenge reply '.$clientip);	$clientok = 1;
	&logthis('<font color="green">'
	."Successful insecure authentication with $clientname </font>");
	print $client "ok\n";
	$keymode = "insecure";
	} else {
	&logthis('<font color="yellow">'
	."Attempted insecure connection disallowed </font>");
	close $client;
	$clientok = 0;

	}
}	}
} else {	} else {
&logthis(	&logthis(
"<font color=blue>WARNING: "	"<font color='blue'>WARNING: "
."$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>");
&status('Hung up on '.$clientip);	&status('Hung up on '.$clientip);
}	}

if ($clientok) {	if ($clientok) {
# ---------------- New known client connecting, could mean machine online again	# ---------------- New known client connecting, could mean machine online again

Line 1346 sub make_new_child {	Line 1619 sub make_new_child {
}	}
&reconlonc("$perlvar{'lonSockDir'}/$id");	&reconlonc("$perlvar{'lonSockDir'}/$id");
}	}
&logthis("<font color=green>Established connection: $clientname</font>");	&logthis("<font color='green'>Established connection: $clientname</font>");
&status('Will listen to '.$clientname);	&status('Will listen to '.$clientname);
# ------------------------------------------------------------ Process requests	# ------------------------------------------------------------ Process requests
while (my $userinput=<$client>) {	while (my $userinput=<$client>) {
Line 1543 sub make_new_child {	Line 1816 sub make_new_child {
$pwdcorrect=0;	$pwdcorrect=0;
# log error if it is not a bad password	# log error if it is not a bad password
if ($krb4_error != 62) {	if ($krb4_error != 62) {
&logthis('krb4:'.$uname.','.$contentpwd.','.	&logthis('krb4:'.$uname.','.
&Authen::Krb4::get_err_txt($Authen::Krb4::error));	&Authen::Krb4::get_err_txt($Authen::Krb4::error));
}	}
}	}
Line 1693 sub make_new_child {	Line 1966 sub make_new_child {
unless (mkdir($fpnow,0777)) {	unless (mkdir($fpnow,0777)) {
$fperror="error: ".($!+0)	$fperror="error: ".($!+0)
." mkdir failed while attempting "	." mkdir failed while attempting "
."makeuser\n";	."makeuser";
}	}
}	}
}	}
Line 1809 sub make_new_child {	Line 2082 sub make_new_child {
} elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.	} elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.
if(isClient) {	if(isClient) {
my ($cmd,$fname)=split(/:/,$userinput);	my ($cmd,$fname)=split(/:/,$userinput);
my ($udom,$uname,$ufile)=split(/\//,$fname);	my ($udom,$uname,$ufile) = ($fname =~ m\|^([^/]+)/([^/]+)/(.+)$\|);
my $udir=propath($udom,$uname).'/userfiles';	my $udir=propath($udom,$uname).'/userfiles';
unless (-e $udir) { mkdir($udir,0770); }	unless (-e $udir) { mkdir($udir,0770); }
if (-e $udir) {	if (-e $udir) {
$ufile=~s/^[\.\~]+//;	$ufile=~s/^[\.\~]+//;
$ufile=~s/\///g;	my $path = $udir;
	if ($ufile =~m\|(.+)/([^/]+)$\|) {
	my @parts=split('/',$1);
	foreach my $part (@parts) {
	$path .= '/'.$part;
	if ((-e $path)!=1) {
	mkdir($path,0770);
	}
	}
	}
my $destname=$udir.'/'.$ufile;	my $destname=$udir.'/'.$ufile;
my $transname=$udir.'/'.$ufile.'.in.transit';	my $transname=$udir.'/'.$ufile.'.in.transit';
my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;	my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
Line 1843 sub make_new_child {	Line 2125 sub make_new_child {
}	}
} else {	} else {
Reply($client, "refused\n", $userinput);	Reply($client, "refused\n", $userinput);
	}
	# --------------------------------------------------------- remove a user file
	} elsif ($userinput =~ /^removeuserfile/) { # Client clear or enc.
	if(isClient) {
	my ($cmd,$fname)=split(/:/,$userinput);
	my ($udom,$uname,$ufile) = ($fname =~ m\|^([^/]+)/([^/]+)/(.+)$\|);
	&logthis("$udom - $uname - $ufile");
	if ($ufile =~m\|/\.\./\|) {
	# any files paths with /../ in them refuse
	# to deal with
	print $client "refused\n";
	} else {
	my $udir=propath($udom,$uname);
	if (-e $udir) {
	my $file=$udir.'/userfiles/'.$ufile;
	if (-e $file) {
	unlink($file);
	if (-e $file) {
	print $client "failed\n";
	} else {
	print $client "ok\n";
	}
	} else {
	print $client "not_found\n";
	}
	} else {
	print $client "not_home\n";
	}
	}
	} else {
	Reply($client, "refused\n", $userinput);
}	}
# ------------------------------------------ authenticate access to a user file	# ------------------------------------------ authenticate access to a user file
} elsif ($userinput =~ /^tokenauthuserfile/) { # Client only	} elsif ($userinput =~ /^tokenauthuserfile/) { # Client only
Line 1854 sub make_new_child {	Line 2166 sub make_new_child {
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.	if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
$session.'.id')) {	$session.'.id')) {
while (my $line=<ENVIN>) {	while (my $line=<ENVIN>) {
if ($line=~/userfile\.$fname\=/) { $reply='ok'; }	if ($line=~ m\|userfile\.\Q$fname\E\=\|) { $reply='ok'; }
}	}
close(ENVIN);	close(ENVIN);
print $client $reply."\n";	print $client $reply."\n";
Line 1870 sub make_new_child {	Line 2182 sub make_new_child {
if(isClient) {	if(isClient) {
my ($cmd,$fname)=split(/:/,$userinput);	my ($cmd,$fname)=split(/:/,$userinput);
if (-e $fname) {	if (-e $fname) {
print $client &unsub($client,$fname,$clientip);	print $client &unsub($fname,$clientip);
} else {	} else {
print $client "not_found\n";	print $client "not_found\n";
}	}
Line 1997 sub make_new_child {	Line 2309 sub make_new_child {
} else {	} else {
print $client "error: ".($!+0)	print $client "error: ".($!+0)
." untie(GDBM) failed ".	." untie(GDBM) failed ".
"while attempting put\n";	"while attempting inc\n";
}	}
} else {	} else {
print $client "error: ".($!)	print $client "error: ".($!)
." tie(GDBM) Failed ".	." tie(GDBM) Failed ".
"while attempting put\n";	"while attempting inc\n";
}	}
} else {	} else {
print $client "refused\n";	print $client "refused\n";
Line 2328 sub make_new_child {	Line 2640 sub make_new_child {
my $proname=propath($udom,$uname);	my $proname=propath($udom,$uname);
my %hash;	my %hash;
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {	if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
study($regexp);
while (my ($key,$value) = each(%hash)) {	while (my ($key,$value) = each(%hash)) {
if ($regexp eq '.') {	if ($regexp eq '.') {
$qresult.=$key.'='.$value.'&';	$qresult.=$key.'='.$value.'&';
Line 2476 sub make_new_child {	Line 2787 sub make_new_child {
}	}
# ------------------------------------------------------------------- querysend	# ------------------------------------------------------------------- querysend
} elsif ($userinput =~ /^querysend/) {	} elsif ($userinput =~ /^querysend/) {
if(isClient) {	if (isClient) {
my ($cmd,$query,	my ($cmd,$query,
$arg1,$arg2,$arg3)=split(/\:/,$userinput);	$arg1,$arg2,$arg3)=split(/\:/,$userinput);
$query=~s/\n*$//g;	$query=~s/\n*$//g;
Line 2524 sub make_new_child {	Line 2835 sub make_new_child {
my %hash;	my %hash;
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
foreach my $pair (@pairs) {	foreach my $pair (@pairs) {
my ($key,$value)=split(/=/,$pair);	my ($key,$descr,$inst_code)=split(/=/,$pair);
$hash{$key}=$value.':'.$now;	$hash{$key}=$descr.':'.$inst_code.':'.$now;
}	}
if (untie(%hash)) {	if (untie(%hash)) {
print $client "ok\n";	print $client "ok\n";
Line 2560 sub make_new_child {	Line 2871 sub make_new_child {
my %hash;	my %hash;
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {	if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
while (my ($key,$value) = each(%hash)) {	while (my ($key,$value) = each(%hash)) {
my ($descr,$lasttime)=split(/\:/,$value);	my ($descr,$lasttime,$inst_code);
	if ($value =~ m/^([^\:]):([^\:]):(\d+)$/) {
	($descr,$inst_code,$lasttime)=($1,$2,$3);
	} else {
	($descr,$lasttime) = split(/\:/,$value);
	}
if ($lasttime<$since) { next; }	if ($lasttime<$since) { next; }
if ($description eq '.') {	if ($description eq '.') {
$qresult.=$key.'='.$descr.'&';	$qresult.=$key.'='.$descr.':'.$inst_code.'&';
} else {	} else {
my $unescapeVal = &unescape($descr);	my $unescapeVal = &unescape($descr);
if (eval('$unescapeVal=~/$description/i')) {	if (eval('$unescapeVal=~/\Q$description\E/i')) {
$qresult.="$key=$descr&";	$qresult.=$key.'='.$descr.':'.$inst_code.'&';
}	}
}	}
}	}
Line 2721 sub make_new_child {	Line 3037 sub make_new_child {
Reply($client, "refused\n", $userinput);	Reply($client, "refused\n", $userinput);

}	}
	# ----------------------------------------- portfolio directory list (portls)
	} elsif ($userinput =~ /^portls/) {
	if(isClient) {
	my ($cmd,$uname,$udom)=split(/:/,$userinput);
	my $udir=propath($udom,$uname).'/userfiles/portfolio';
	my $dirLine='';
	my $dirContents='';
	if (opendir(LSDIR,$udir.'/')){
	while ($dirLine = readdir(LSDIR)){
	$dirContents = $dirContents.$dirLine.'<br />';
	}
	} else {
	$dirContents = "No directory found\n";
	}
	print $client $dirContents."\n";
	} else {
	Reply($client, "refused\n", $userinput);
	}
# -------------------------------------------------------------------------- ls	# -------------------------------------------------------------------------- ls
} elsif ($userinput =~ /^ls/) {	} elsif ($userinput =~ /^ls/) {
if(isClient) {	if(isClient) {
	my $obs;
	my $rights;
my ($cmd,$ulsdir)=split(/:/,$userinput);	my ($cmd,$ulsdir)=split(/:/,$userinput);
my $ulsout='';	my $ulsout='';
my $ulsfn;	my $ulsfn;
Line 2731 sub make_new_child {	Line 3067 sub make_new_child {
if(-d $ulsdir) {	if(-d $ulsdir) {
if (opendir(LSDIR,$ulsdir)) {	if (opendir(LSDIR,$ulsdir)) {
while ($ulsfn=readdir(LSDIR)) {	while ($ulsfn=readdir(LSDIR)) {
	undef $obs, $rights;
my @ulsstats=stat($ulsdir.'/'.$ulsfn);	my @ulsstats=stat($ulsdir.'/'.$ulsfn);
$ulsout.=$ulsfn.'&'.	#We do some obsolete checking here
join('&',@ulsstats).':';	if(-e $ulsdir.'/'.$ulsfn.".meta") {
	open(FILE, $ulsdir.'/'.$ulsfn.".meta");
	my @obsolete=<FILE>;
	foreach my $obsolete (@obsolete) {
	if($obsolete =~ m\|(<obsolete>)(on)\|) { $obs = 1; }
	if($obsolete =~ m\|(<copyright>)(default)\|) { $rights = 1; }
	}
	}
	$ulsout.=$ulsfn.'&'.join('&',@ulsstats);
	if($obs eq '1') { $ulsout.="&1"; }
	else { $ulsout.="&0"; }
	if($rights eq '1') { $ulsout.="&1:"; }
	else { $ulsout.="&0:"; }
}	}
closedir(LSDIR);	closedir(LSDIR);
}	}
Line 2792 sub make_new_child {	Line 3141 sub make_new_child {
} else {	} else {
print $client "refused\n";	print $client "refused\n";
}	}
	#------------------------------- is auto-enrollment enabled?
	} elsif ($userinput =~/^autorun:/) {
	if (isClient) {
	my ($cmd,$cdom) = split(/:/,$userinput);
	my $outcome = &localenroll::run($cdom);
	print $client "$outcome\n";
	} else {
	print $client "0\n";
	}
	#------------------------------- get official sections (for auto-enrollment).
	} elsif ($userinput =~/^autogetsections:/) {
	if (isClient) {
	my ($cmd,$coursecode,$cdom)=split(/:/,$userinput);
	my @secs = &localenroll::get_sections($coursecode,$cdom);
	my $seclist = &escape(join(':',@secs));
	print $client "$seclist\n";
	} else {
	print $client "refused\n";
	}
	#----------------------- validate owner of new course section (for auto-enrollment).
	} elsif ($userinput =~/^autonewcourse:/) {
	if (isClient) {
	my ($cmd,$inst_course_id,$owner,$cdom)=split(/:/,$userinput);
	my $outcome = &localenroll::new_course($inst_course_id,$owner,$cdom);
	print $client "$outcome\n";
	} else {
	print $client "refused\n";
	}
	#-------------- validate course section in schedule of classes (for auto-enrollment).
	} elsif ($userinput =~/^autovalidatecourse:/) {
	if (isClient) {
	my ($cmd,$inst_course_id,$cdom)=split(/:/,$userinput);
	my $outcome=&localenroll::validate_courseID($inst_course_id,$cdom);
	print $client "$outcome\n";
	} else {
	print $client "refused\n";
	}
	#--------------------------- create password for new user (for auto-enrollment).
	} elsif ($userinput =~/^autocreatepassword:/) {
	if (isClient) {
	my ($cmd,$authparam,$cdom)=split(/:/,$userinput);
	my ($create_passwd,$authchk);
	($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam,$cdom);
	print $client &escape($authparam.':'.$create_passwd.':'.$authchk)."\n";
	} else {
	print $client "refused\n";
	}
	#--------------------------- read and remove temporary files (for auto-enrollment).
	} elsif ($userinput =~/^autoretrieve:/) {
	if (isClient) {
	my ($cmd,$filename) = split(/:/,$userinput);
	my $source = $perlvar{'lonDaemons'}.'/tmp/'.$filename;
	if ( (-e $source) && ($filename ne '') ) {
	my $reply = '';
	if (open(my $fh,$source)) {
	while (<$fh>) {
	chomp($_);
	$_ =~ s/^\s+//g;
	$_ =~ s/\s+$//g;
	$reply .= $_;
	}
	close($fh);
	print $client &escape($reply)."\n";
	# unlink($source);
	} else {
	print $client "error\n";
	}
	} else {
	print $client "error\n";
	}
	} else {
	print $client "refused\n";
	}
# ------------------------------------------------------------- unknown command	# ------------------------------------------------------------- unknown command

} else {	} else {
Line 2800 sub make_new_child {	Line 3222 sub make_new_child {
}	}
# -------------------------------------------------------------------- complete	# -------------------------------------------------------------------- complete
alarm(0);	alarm(0);
&status('Listening to '.$clientname);	&status('Listening to '.$clientname." ($keymode)");
}	}
# --------------------------------------------- client unknown or fishy, refuse	# --------------------------------------------- client unknown or fishy, refuse
} else {	} else {
print $client "refused\n";	print $client "refused\n";
$client->close();	$client->close();
&logthis("<font color=blue>WARNING: "	&logthis("<font color='blue'>WARNING: "
."Rejected client $clientip, closing connection</font>");	."Rejected client $clientip, closing connection</font>");
}	}
}	}

# =============================================================================	# =============================================================================

&logthis("<font color=red>CRITICAL: "	&logthis("<font color='red'>CRITICAL: "
."Disconnect from $clientip ($clientname)</font>");	."Disconnect from $clientip ($clientname)</font>");


Line 2838 sub make_new_child {	Line 3260 sub make_new_child {
#	#
sub ManagePermissions	sub ManagePermissions
{	{
my $request = shift;
my $domain = shift;	my ($request, $domain, $user, $authtype) = @_;
my $user = shift;
my $authtype= shift;

# See if the request is of the form /$domain/_au	# See if the request is of the form /$domain/_au
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...	if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
Line 2858 sub ManagePermissions	Line 3278 sub ManagePermissions
#	#
sub GetAuthType	sub GetAuthType
{	{
my $domain = shift;
my $user = shift;	my ($domain, $user) = @_;

Debug("GetAuthType( $domain, $user ) \n");	Debug("GetAuthType( $domain, $user ) \n");
my $proname = &propath($domain, $user);	my $proname = &propath($domain, $user);
Line 2968 sub chatadd {	Line 3388 sub chatadd {
sub unsub {	sub unsub {
my ($fname,$clientip)=@_;	my ($fname,$clientip)=@_;
my $result;	my $result;
	my $unsubs = 0; # Number of successful unsubscribes:


	# An old way subscriptions were handled was to have a
	# subscription marker file:

	Debug("Attempting unlink of $fname.$clientname");
if (unlink("$fname.$clientname")) {	if (unlink("$fname.$clientname")) {
$result="ok\n";	$unsubs++; # Successful unsub via marker file.
} else {	}
$result="not_subscribed\n";
}	# The more modern way to do it is to have a subscription list
	# file:

if (-e "$fname.subscription") {	if (-e "$fname.subscription") {
my $found=&addline($fname,$clientname,$clientip,'');	my $found=&addline($fname,$clientname,$clientip,'');
if ($found) { $result="ok\n"; }	if ($found) {
	$unsubs++;
	}
	}

	# If either or both of these mechanisms succeeded in unsubscribing a
	# resource we can return ok:

	if($unsubs) {
	$result = "ok\n";
} else {	} else {
if ($result != "ok\n") { $result="not_subscribed\n"; }	$result = "not_subscribed\n";
}	}

return $result;	return $result;
}	}

Line 3100 sub make_passwd_file {	Line 3539 sub make_passwd_file {
}	}
} elsif ($umode eq 'unix') {	} elsif ($umode eq 'unix') {
{	{
	#
	# Don't allow the creation of privileged accounts!!! that would
	# be real bad!!!
	#
	my $uid = getpwnam($uname);
	if((defined $uid) && ($uid == 0)) {
	&logthis(">>>Attempted to create privilged account blocked");
	return "no_priv_account_error\n";
	}

my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";	my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd";
{	{
&Debug("Executing external: ".$execpath);	&Debug("Executing external: ".$execpath);
Line 3132 sub sethost {	Line 3581 sub sethost {
my (undef,$hostid)=split(/:/,$remotereq);	my (undef,$hostid)=split(/:/,$remotereq);
if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }	if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {	if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
$currenthostid=$hostid;	$currenthostid =$hostid;
$currentdomainid=$hostdom{$hostid};	$currentdomainid=$hostdom{$hostid};
&logthis("Setting hostid to $hostid, and domain to $currentdomainid");	&logthis("Setting hostid to $hostid, and domain to $currentdomainid");
} else {	} else {
Line 3172 sub userload {	Line 3621 sub userload {
return $userloadpercent;	return $userloadpercent;
}	}


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

=head1 NAME	=head1 NAME

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

Removed from v.1.170
changed lines
	Added in v.1.204