--- loncom/lond 2003/12/12 21:37:42 1.165
+++ loncom/lond 2004/06/29 15:19:56 1.203
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.165 2003/12/12 21:37:42 albertel Exp $
+# $Id: lond,v 1.203 2004/06/29 15:19:56 albertel Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -10,7 +10,7 @@
#
# LON-CAPA is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
+# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# LON-CAPA is distributed in the hope that it will be useful,
@@ -45,24 +45,31 @@ use Authen::Krb4;
use Authen::Krb5;
use lib '/home/httpd/lib/perl/';
use localauth;
+use localenroll;
use File::Copy;
+use LONCAPA::ConfigFileEdit;
+use LONCAPA::lonlocal;
+use LONCAPA::lonssl;
-my $DEBUG = 0; # Non zero to enable debug log entries.
+my $DEBUG = 11; # Non zero to enable debug log entries.
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.165 $'; #' stupid emacs
+my $VERSION='$Revision: 1.203 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid;
my $currentdomainid;
my $client;
-my $clientip;
-my $clientname;
+my $clientip; # IP address of client.
+my $clientdns; # DNS name of client.
+my $clientname; # LonCAPA name of client.
my $server;
-my $thisserver;
+my $thisserver; # DNS of us.
+
+my $keymode;
#
# Connection type is:
@@ -73,9 +80,10 @@ my $thisserver;
my $ConnectionType;
-my %hostid;
-my %hostdom;
-my %hostip;
+my %hostid; # ID's for hosts in cluster by ip.
+my %hostdom; # LonCAPA domain for hosts in cluster.
+my %hostip; # IPs for hosts in cluster.
+my %hostdns; # ID's of hosts looked up by DNS name.
my %managers; # Ip -> manager names
@@ -119,6 +127,178 @@ my @adderrors = ("ok",
"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,
# this function will extract the certificate from the transaction
@@ -162,37 +342,41 @@ sub ReadManagerTable {
# Clean out the old table first..
- foreach my $key (keys %managers) {
- delete $managers{$key};
- }
-
- my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
- if (!open (MANAGERS, $tablename)) {
- logthis('<font color="red">No manager table. Nobody can manage!!</font>');
- return;
- }
- while(my $host = <MANAGERS>) {
- chomp($host);
- if (!defined $hostip{$host}) { # This is a non cluster member
-
+ foreach my $key (keys %managers) {
+ delete $managers{$key};
+ }
+
+ my $tablename = $perlvar{'lonTabDir'}."/managers.tab";
+ if (!open (MANAGERS, $tablename)) {
+ logthis('<font color="red">No manager table. Nobody can manage!!</font>');
+ return;
+ }
+ while(my $host = <MANAGERS>) {
+ chomp($host);
+ if ($host =~ "^#") { # Comment line.
+ next;
+ }
+ if (!defined $hostip{$host}) { # This is a non cluster member
# The entry is of the form:
# cluname:hostname
# cluname - A 'cluster hostname' is needed in order to negotiate
# the host key.
# hostname- The dns name of the host.
#
-
- my($cluname, $dnsname) = split(/:/, $host);
- open(MGRPIPE, "/usr/bin/host $dnsname |") || die "Can't make host pipeline";
- my $dnsinfo = <MGRPIPE>;
- chomp $dnsinfo;
- close MGRPIPE;
- my($jname, $jhas, $jaddress, $hostip) = split(/ /, $dnsinfo);
- $managers{$hostip} = $cluname;
- } else {
- $managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber
- }
- }
+ my($cluname, $dnsname) = split(/:/, $host);
+
+ my $ip = gethostbyname($dnsname);
+ if(defined($ip)) { # bad names don't deserve entry.
+ my $hostip = inet_ntoa($ip);
+ $managers{$hostip} = $cluname;
+ logthis('<font color="green"> registering manager '.
+ "$dnsname as $cluname with $hostip </font>\n");
+ }
+ } else {
+ logthis('<font color="green"> existing host'." $host</font>\n");
+ $managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber
+ }
+ }
}
#
@@ -219,8 +403,8 @@ sub ValidManager {
# 1 - Success.
#
sub CopyFile {
- my $oldfile = shift;
- my $newfile = shift;
+
+ my ($oldfile, $newfile) = @_;
# The file must exist:
@@ -279,42 +463,30 @@ sub AdjustHostContents {
my $adjusted;
my $me = $perlvar{'lonHostID'};
- foreach my $line (split(/\n/,$contents)) {
+ foreach my $line (split(/\n/,$contents)) {
if(!(($line eq "") || ($line =~ /^ *\#/) || ($line =~ /^ *$/))) {
chomp($line);
my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon)=split(/:/,$line);
if ($id eq $me) {
- open(PIPE, " /usr/bin/host $name |") || die "Cant' make host pipeline";
- my $hostinfo = <PIPE>;
- close PIPE;
-
- my ($hostname, $has, $address, $ipnew) = split(/ /,$hostinfo);
- &logthis('<font color="green">'.
- "hostname = $hostname me = $me, name = $name actual ip = $ipnew </font>");
-
- if ($hostname eq $name) { # Lookup succeeded..
- &logthis('<font color="green"> look up ok <font>');
- $ip = $ipnew;
- } else {
- &logthis('<font color="green"> Lookup failed: '
- .$hostname." ne $name </font>");
- }
+ my $ip = gethostbyname($name);
+ my $ipnew = inet_ntoa($ip);
+ $ip = $ipnew;
# Reconstruct the host line and append to adjusted:
- my $newline = "$id:$domain:$role:$name:$ip";
- if($maxcon ne "") { # Not all hosts have loncnew tuning params
- $newline .= ":$maxcon:$idleto:$mincon";
- }
- $adjusted .= $newline."\n";
+ my $newline = "$id:$domain:$role:$name:$ip";
+ if($maxcon ne "") { # Not all hosts have loncnew tuning params
+ $newline .= ":$maxcon:$idleto:$mincon";
+ }
+ $adjusted .= $newline."\n";
- } else { # Not me, pass unmodified.
- $adjusted .= $line."\n";
- }
+ } else { # Not me, pass unmodified.
+ $adjusted .= $line."\n";
+ }
} else { # Blank or comment never re-written.
$adjusted .= $line."\n"; # Pass blanks and comments as is.
}
- }
- return $adjusted;
+ }
+ return $adjusted;
}
#
# InstallFile: Called to install an administrative file:
@@ -332,8 +504,8 @@ sub AdjustHostContents {
# 0 - failure and $! has an errno.
#
sub InstallFile {
- my $Filename = shift;
- my $Contents = shift;
+
+ my ($Filename, $Contents) = @_;
my $TempFile = $Filename.".tmp";
# Open the file for write:
@@ -357,6 +529,32 @@ sub InstallFile {
return 1;
}
+
+#
+# ConfigFileFromSelector: converts a configuration file selector
+# (one of host or domain at this point) into a
+# configuration file pathname.
+#
+# Parameters:
+# selector - Configuration file selector.
+# Returns:
+# Full path to the file or undef if the selector is invalid.
+#
+sub ConfigFileFromSelector {
+ my $selector = shift;
+ my $tablefile;
+
+ my $tabledir = $perlvar{'lonTabDir'}.'/';
+ if ($selector eq "hosts") {
+ $tablefile = $tabledir."hosts.tab";
+ } elsif ($selector eq "domain") {
+ $tablefile = $tabledir."domain.tab";
+ } else {
+ return undef;
+ }
+ return $tablefile;
+
+}
#
# PushFile: Called to do an administrative push of a file.
# - Ensure the file being pushed is one we support.
@@ -386,12 +584,9 @@ sub PushFile {
# part of some elaborate spoof that managed somehow to authenticate.
#
- my $tablefile = $perlvar{'lonTabDir'}.'/'; # need to precede with dir.
- if ($filename eq "host") {
- $tablefile .= "hosts.tab";
- } elsif ($filename eq "domain") {
- $tablefile .= "domain.tab";
- } else {
+
+ my $tablefile = ConfigFileFromSelector($filename);
+ if(! (defined $tablefile)) {
return "refused";
}
#
@@ -483,7 +678,227 @@ sub ReinitProcess {
}
return 'ok';
}
+# Validate a line in a configuration file edit script:
+# Validation includes:
+# - Ensuring the command is valid.
+# - Ensuring the command has sufficient parameters
+# Parameters:
+# scriptline - A line to validate (\n has been stripped for what it's worth).
+#
+# Return:
+# 0 - Invalid scriptline.
+# 1 - Valid scriptline
+# NOTE:
+# Only the command syntax is checked, not the executability of the
+# command.
+#
+sub isValidEditCommand {
+ my $scriptline = shift;
+
+ # Line elements are pipe separated:
+
+ my ($command, $key, $newline) = split(/\|/, $scriptline);
+ &logthis('<font color="green"> isValideditCommand checking: '.
+ "Command = '$command', Key = '$key', Newline = '$newline' </font>\n");
+
+ if ($command eq "delete") {
+ #
+ # key with no newline.
+ #
+ if( ($key eq "") || ($newline ne "")) {
+ return 0; # Must have key but no newline.
+ } else {
+ return 1; # Valid syntax.
+ }
+ } elsif ($command eq "replace") {
+ #
+ # key and newline:
+ #
+ if (($key eq "") || ($newline eq "")) {
+ return 0;
+ } else {
+ return 1;
+ }
+ } elsif ($command eq "append") {
+ if (($key ne "") && ($newline eq "")) {
+ return 1;
+ } else {
+ return 0;
+ }
+ } else {
+ return 0; # Invalid command.
+ }
+ return 0; # Should not get here!!!
+}
+#
+# ApplyEdit - Applies an edit command to a line in a configuration
+# file. It is the caller's responsiblity to validate the
+# edit line.
+# Parameters:
+# $directive - A single edit directive to apply.
+# Edit directives are of the form:
+# append|newline - Appends a new line to the file.
+# replace|key|newline - Replaces the line with key value 'key'
+# delete|key - Deletes the line with key value 'key'.
+# $editor - A config file editor object that contains the
+# file being edited.
+#
+sub ApplyEdit {
+
+ my ($directive, $editor) = @_;
+
+ # Break the directive down into its command and its parameters
+ # (at most two at this point. The meaning of the parameters, if in fact
+ # they exist depends on the command).
+
+ my ($command, $p1, $p2) = split(/\|/, $directive);
+
+ if($command eq "append") {
+ $editor->Append($p1); # p1 - key p2 null.
+ } elsif ($command eq "replace") {
+ $editor->ReplaceLine($p1, $p2); # p1 - key p2 = newline.
+ } elsif ($command eq "delete") {
+ $editor->DeleteLine($p1); # p1 - key p2 null.
+ } else { # Should not get here!!!
+ die "Invalid command given to ApplyEdit $command"
+ }
+}
+#
+# AdjustOurHost:
+# Adjusts a host file stored in a configuration file editor object
+# for the true IP address of this host. This is necessary for hosts
+# that live behind a firewall.
+# Those hosts have a publicly distributed IP of the firewall, but
+# internally must use their actual IP. We assume that a given
+# host only has a single IP interface for now.
+# Formal Parameters:
+# editor - The configuration file editor to adjust. This
+# editor is assumed to contain a hosts.tab file.
+# Strategy:
+# - Figure out our hostname.
+# - Lookup the entry for this host.
+# - Modify the line to contain our IP
+# - Do a replace for this host.
+sub AdjustOurHost {
+ my $editor = shift;
+
+ # figure out who I am.
+
+ my $myHostName = $perlvar{'lonHostID'}; # LonCAPA hostname.
+
+ # Get my host file entry.
+
+ my $ConfigLine = $editor->Find($myHostName);
+ if(! (defined $ConfigLine)) {
+ die "AdjustOurHost - no entry for me in hosts file $myHostName";
+ }
+ # figure out my IP:
+ # Use the config line to get my hostname.
+ # Use gethostbyname to translate that into an IP address.
+ #
+ my ($id,$domain,$role,$name,$ip,$maxcon,$idleto,$mincon) = split(/:/,$ConfigLine);
+ my $BinaryIp = gethostbyname($name);
+ my $ip = inet_ntoa($ip);
+ #
+ # Reassemble the config line from the elements in the list.
+ # Note that if the loncnew items were not present before, they will
+ # be now even if they would be empty
+ #
+ my $newConfigLine = $id;
+ foreach my $item ($domain, $role, $name, $ip, $maxcon, $idleto, $mincon) {
+ $newConfigLine .= ":".$item;
+ }
+ # Replace the line:
+
+ $editor->ReplaceLine($id, $newConfigLine);
+
+}
+#
+# ReplaceConfigFile:
+# Replaces a configuration file with the contents of a
+# configuration file editor object.
+# This is done by:
+# - Copying the target file to <filename>.old
+# - Writing the new file to <filename>.tmp
+# - Moving <filename.tmp> -> <filename>
+# This laborious process ensures that the system is never without
+# a configuration file that's at least valid (even if the contents
+# may be dated).
+# Parameters:
+# filename - Name of the file to modify... this is a full path.
+# editor - Editor containing the file.
+#
+sub ReplaceConfigFile {
+
+ my ($filename, $editor) = @_;
+
+ CopyFile ($filename, $filename.".old");
+
+ my $contents = $editor->Get(); # Get the contents of the file.
+
+ InstallFile($filename, $contents);
+}
+#
+#
+# Called to edit a configuration table file
+# Parameters:
+# request - The entire command/request sent by lonc or lonManage
+# Return:
+# The reply to send to the client.
+#
+sub EditFile {
+ my $request = shift;
+
+ # Split the command into it's pieces: edit:filetype:script
+
+ my ($request, $filetype, $script) = split(/:/, $request,3); # : in script
+
+ # Check the pre-coditions for success:
+
+ if($request != "edit") { # Something is amiss afoot alack.
+ return "error:edit request detected, but request != 'edit'\n";
+ }
+ if( ($filetype ne "hosts") &&
+ ($filetype ne "domain")) {
+ return "error:edit requested with invalid file specifier: $filetype \n";
+ }
+ # Split the edit script and check it's validity.
+
+ my @scriptlines = split(/\n/, $script); # one line per element.
+ my $linecount = scalar(@scriptlines);
+ for(my $i = 0; $i < $linecount; $i++) {
+ chomp($scriptlines[$i]);
+ if(!isValidEditCommand($scriptlines[$i])) {
+ return "error:edit with bad script line: '$scriptlines[$i]' \n";
+ }
+ }
+
+ # Execute the edit operation.
+ # - Create a config file editor for the appropriate file and
+ # - execute each command in the script:
+ #
+ my $configfile = ConfigFileFromSelector($filetype);
+ if (!(defined $configfile)) {
+ return "refused\n";
+ }
+ my $editor = ConfigFileEdit->new($configfile);
+
+ for (my $i = 0; $i < $linecount; $i++) {
+ ApplyEdit($scriptlines[$i], $editor);
+ }
+ # If the file is the host file, ensure that our host is
+ # adjusted to have our ip:
+ #
+ if($filetype eq "host") {
+ AdjustOurHost($editor);
+ }
+ # Finally replace the current file with our file.
+ #
+ ReplaceConfigFile($configfile, $editor);
+
+ return "ok\n";
+}
#
# Convert an error return code from lcpasswd to a string value.
#
@@ -514,7 +929,7 @@ sub catchexception {
$SIG{'QUIT'}='DEFAULT';
$SIG{__DIE__}='DEFAULT';
&status("Catching exception");
- &logthis("<font color=red>CRITICAL: "
+ &logthis("<font color='red'>CRITICAL: "
."ABNORMAL EXIT. Child $$ for server $thisserver died through "
."a crash with this error msg->[$error]</font>");
&logthis('Famous last words: '.$status.' - '.$lastlog);
@@ -525,7 +940,7 @@ sub catchexception {
sub timeout {
&status("Handling Timeout");
- &logthis("<font color=ref>CRITICAL: TIME OUT ".$$."</font>");
+ &logthis("<font color='red'>CRITICAL: TIME OUT ".$$."</font>");
&catchexception('Timeout');
}
# -------------------------------- Set signal handlers to record abnormal exits
@@ -577,18 +992,26 @@ $server = IO::Socket::INET->new(LocalPor
# global variables
my %children = (); # keys are current child process IDs
-my $children = 0; # current number of children
sub REAPER { # takes care of dead children
$SIG{CHLD} = \&REAPER;
&status("Handling child death");
- my $pid = wait;
- if (defined($children{$pid})) {
- &logthis("Child $pid died");
- $children --;
- delete $children{$pid};
- } else {
- &logthis("Unknown Child $pid died");
+ my $pid;
+ do {
+ $pid = waitpid(-1,&WNOHANG());
+ if (defined($children{$pid})) {
+ &logthis("Child $pid died");
+ delete($children{$pid});
+ } 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");
}
@@ -600,7 +1023,7 @@ sub HUNTSMAN { # si
&logthis("Free socket: ".shutdown($server,2)); # free up socket
my $execdir=$perlvar{'lonDaemons'};
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");
exit; # clean up with dignity
}
@@ -610,7 +1033,7 @@ sub HUPSMAN { # sig
&status("Killing children for restart (HUP)");
kill 'INT' => keys %children;
&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'};
unlink("$execdir/logs/lond.pid");
&status("Restarting self (HUP)");
@@ -620,7 +1043,7 @@ sub HUPSMAN { # sig
#
# Kill off hashes that describe the host table prior to re-reading it.
# Hashes affected are:
-# %hostid, %hostdom %hostip
+# %hostid, %hostdom %hostip %hostdns.
#
sub KillHostHashes {
foreach my $key (keys %hostid) {
@@ -632,6 +1055,9 @@ sub KillHostHashes {
foreach my $key (keys %hostip) {
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:
@@ -642,14 +1068,22 @@ sub KillHostHashes {
sub ReadHostTable {
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>) {
- my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
- chomp($ip); $ip=~s/\D+$//;
- $hostid{$ip}=$id;
- $hostdom{$id}=$domain;
- $hostip{$id}=$ip;
- if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
+ if (!($configline =~ /^\s*\#/)) {
+ my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
+ chomp($ip); $ip=~s/\D+$//;
+ $hostid{$ip}=$id; # LonCAPA name of host by IP.
+ $hostdom{$id}=$domain; # LonCAPA domain name of host.
+ $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);
}
@@ -770,9 +1204,8 @@ sub Debug {
# request - Original request from client.
#
sub Reply {
- my $fd = shift;
- my $reply = shift;
- my $request = shift;
+
+ my ($fd, $reply, $request) = @_;
print $fd $reply;
Debug("Request was $request Reply was $reply");
@@ -785,13 +1218,14 @@ sub logstatus {
my $docdir=$perlvar{'lonDocRoot'};
{
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();
}
&status("Finished londstatus.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();
}
&status("Finished logging");
@@ -850,11 +1284,11 @@ sub reconlonc {
kill USR1 => $loncpid;
} else {
&logthis(
- "<font color=red>CRITICAL: "
+ "<font color='red'>CRITICAL: "
."lonc at pid $loncpid not responding, giving up</font>");
}
} else {
- &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');
+ &logthis('<font color="red">CRITICAL: lonc not running, giving up</font>');
}
}
@@ -958,7 +1392,7 @@ my $execdir=$perlvar{'lonDaemons'};
open (PIDSAVE,">$execdir/logs/lond.pid");
print PIDSAVE "$$\n";
close(PIDSAVE);
-&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
+&logthis("<font color='red'>CRITICAL: ---------- Starting ----------</font>");
&status('Starting');
@@ -1013,15 +1447,27 @@ sub make_new_child {
# the pid hash.
#
my $caller = getpeername($client);
- my ($port,$iaddr)=unpack_sockaddr_in($caller);
- $clientip=inet_ntoa($iaddr);
+ my ($port,$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) {
# Parent records the child's birth and returns.
sigprocmask(SIG_UNBLOCK, $sigset)
or die "Can't unblock SIGINT for fork: $!\n";
$children{$pid} = $clientip;
- $children++;
&status('Started child '.$pid);
return;
} else {
@@ -1047,7 +1493,7 @@ sub make_new_child {
# =============================================================================
# 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!!
@@ -1065,6 +1511,7 @@ sub make_new_child {
$clientname = $managers{$clientip};
}
my $clientok;
+
if ($clientrec || $ismanager) {
&status("Waiting for init from $clientip $clientname");
&logthis('<font color="yellow">INFO: Connection, '.
@@ -1072,34 +1519,95 @@ sub make_new_child {
" ($clientname) connection type = $ConnectionType </font>" );
&status("Connecting $clientip ($clientname))");
my $remotereq=<$client>;
- $remotereq=~s/[^\w:]//g;
+ chomp($remotereq);
+ Debug("Got init: $remotereq");
+ my $inikeyword = split(/:/, $remotereq);
if ($remotereq =~ /^init/) {
&sethost("sethost:$perlvar{'lonHostID'}");
- my $challenge="$$".time;
- print $client "$challenge\n";
- &status(
- "Waiting for challenge reply from $clientip ($clientname)");
- $remotereq=<$client>;
- $remotereq=~s/\W//g;
- if ($challenge eq $remotereq) {
- $clientok=1;
- print $client "ok\n";
+ #
+ # If the remote is attempting a local init... give that a try:
+ #
+ my ($i, $inittype) = split(/:/, $remotereq);
+
+ # If the connection type is ssl, but I didn't get my
+ # certificate files yet, then I'll drop back to
+ # insecure (if allowed).
+
+ 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 {
- &logthis(
- "<font color=blue>WARNING: $clientip did not reply challenge</font>");
- &status('No challenge reply '.$clientip);
+ my $ok = InsecureConnection($client);
+ if($ok) {
+ $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 {
&logthis(
- "<font color=blue>WARNING: "
+ "<font color='blue'>WARNING: "
."$clientip failed to initialize: >$remotereq< </font>");
&status('No init '.$clientip);
}
+
} else {
&logthis(
- "<font color=blue>WARNING: Unknown client $clientip</font>");
+ "<font color='blue'>WARNING: Unknown client $clientip</font>");
&status('Hung up on '.$clientip);
}
+
if ($clientok) {
# ---------------- New known client connecting, could mean machine online again
@@ -1111,7 +1619,7 @@ sub make_new_child {
}
&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);
# ------------------------------------------------------------ Process requests
while (my $userinput=<$client>) {
@@ -1224,22 +1732,41 @@ sub make_new_child {
}
#--------------------------------------------------------------------- reinit
} elsif($userinput =~ /^reinit/) { # Encoded and manager
- if (($wasenc == 1) && isManager) {
- my $cert = GetCertificate($userinput);
- if(ValidManager($cert)) {
- chomp($userinput);
- my $reply = ReinitProcess($userinput);
- print $client "$reply\n";
+ if (($wasenc == 1) && isManager) {
+ my $cert = GetCertificate($userinput);
+ if(ValidManager($cert)) {
+ chomp($userinput);
+ my $reply = ReinitProcess($userinput);
+ print $client "$reply\n";
+ } else {
+ print $client "refused\n";
+ }
} else {
- print $client "refused\n";
+ Reply($client, "refused\n", $userinput);
}
- } else {
- Reply($client, "refused\n", $userinput);
-
-
- }
+#------------------------------------------------------------------------- edit
+ } elsif ($userinput =~ /^edit/) { # encoded and manager:
+ if(($wasenc ==1) && (isManager)) {
+ my $cert = GetCertificate($userinput);
+ if(ValidManager($cert)) {
+ my($command, $filetype, $script) = split(/:/, $userinput);
+ if (($filetype eq "hosts") || ($filetype eq "domain")) {
+ if($script ne "") {
+ Reply($client, EditFile($userinput));
+ } else {
+ Reply($client,"refused\n",$userinput);
+ }
+ } else {
+ Reply($client,"refused\n",$userinput);
+ }
+ } else {
+ Reply($client,"refused\n",$userinput);
+ }
+ } else {
+ Reply($client,"refused\n",$userinput);
+ }
# ------------------------------------------------------------------------ auth
- } elsif ($userinput =~ /^auth/) { # Encoded and client only.
+ } elsif ($userinput =~ /^auth/) { # Encoded and client only.
if (($wasenc==1) && isClient) {
my ($cmd,$udom,$uname,$upass)=split(/:/,$userinput);
chomp($upass);
@@ -1289,7 +1816,7 @@ sub make_new_child {
$pwdcorrect=0;
# log error if it is not a bad password
if ($krb4_error != 62) {
- &logthis('krb4:'.$uname.','.$contentpwd.','.
+ &logthis('krb4:'.$uname.','.
&Authen::Krb4::get_err_txt($Authen::Krb4::error));
}
}
@@ -1439,7 +1966,7 @@ sub make_new_child {
unless (mkdir($fpnow,0777)) {
$fperror="error: ".($!+0)
." mkdir failed while attempting "
- ."makeuser\n";
+ ."makeuser";
}
}
}
@@ -1555,12 +2082,21 @@ sub make_new_child {
} elsif ($userinput =~ /^fetchuserfile/) { # Client clear or enc.
if(isClient) {
my ($cmd,$fname)=split(/:/,$userinput);
- my ($udom,$uname,$ufile)=split(/\//,$fname);
+ my ($udom,$uname,$ufile) = ($fname =~ m|^([^/]+)/([^/]+)/(.+)$|);
my $udir=propath($udom,$uname).'/userfiles';
unless (-e $udir) { mkdir($udir,0770); }
if (-e $udir) {
- $ufile=~s/^[\.\~]+//;
- $ufile=~s/\///g;
+ $ufile=~s/^[\.\~]+//;
+ 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 $transname=$udir.'/'.$ufile.'.in.transit';
my $remoteurl='http://'.$clientip.'/userfiles/'.$fname;
@@ -1589,7 +2125,37 @@ sub make_new_child {
}
} else {
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
} elsif ($userinput =~ /^tokenauthuserfile/) { # Client only
@@ -1600,7 +2166,7 @@ sub make_new_child {
if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'.
$session.'.id')) {
while (my $line=<ENVIN>) {
- if ($line=~/userfile\.$fname\=/) { $reply='ok'; }
+ if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; }
}
close(ENVIN);
print $client $reply."\n";
@@ -1616,7 +2182,7 @@ sub make_new_child {
if(isClient) {
my ($cmd,$fname)=split(/:/,$userinput);
if (-e $fname) {
- print $client &unsub($client,$fname,$clientip);
+ print $client &unsub($fname,$clientip);
} else {
print $client "not_found\n";
}
@@ -1743,12 +2309,12 @@ sub make_new_child {
} else {
print $client "error: ".($!+0)
." untie(GDBM) failed ".
- "while attempting put\n";
+ "while attempting inc\n";
}
} else {
print $client "error: ".($!)
." tie(GDBM) Failed ".
- "while attempting put\n";
+ "while attempting inc\n";
}
} else {
print $client "refused\n";
@@ -2074,7 +2640,6 @@ sub make_new_child {
my $proname=propath($udom,$uname);
my %hash;
if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) {
- study($regexp);
while (my ($key,$value) = each(%hash)) {
if ($regexp eq '.') {
$qresult.=$key.'='.$value.'&';
@@ -2222,7 +2787,7 @@ sub make_new_child {
}
# ------------------------------------------------------------------- querysend
} elsif ($userinput =~ /^querysend/) {
- if(isClient) {
+ if (isClient) {
my ($cmd,$query,
$arg1,$arg2,$arg3)=split(/\:/,$userinput);
$query=~s/\n*$//g;
@@ -2270,8 +2835,8 @@ sub make_new_child {
my %hash;
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) {
foreach my $pair (@pairs) {
- my ($key,$value)=split(/=/,$pair);
- $hash{$key}=$value.':'.$now;
+ my ($key,$descr,$inst_code)=split(/=/,$pair);
+ $hash{$key}=$descr.':'.$inst_code.':'.$now;
}
if (untie(%hash)) {
print $client "ok\n";
@@ -2306,14 +2871,19 @@ sub make_new_child {
my %hash;
if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) {
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 ($description eq '.') {
- $qresult.=$key.'='.$descr.'&';
+ $qresult.=$key.'='.$descr.':'.$inst_code.'&';
} else {
my $unescapeVal = &unescape($descr);
- if (eval('$unescapeVal=~/$description/i')) {
- $qresult.="$key=$descr&";
+ if (eval('$unescapeVal=~/\Q$description\E/i')) {
+ $qresult.=$key.'='.$descr.':'.$inst_code.'&';
}
}
}
@@ -2467,9 +3037,29 @@ sub make_new_child {
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
} elsif ($userinput =~ /^ls/) {
if(isClient) {
+ my $obs;
+ my $rights;
my ($cmd,$ulsdir)=split(/:/,$userinput);
my $ulsout='';
my $ulsfn;
@@ -2477,9 +3067,22 @@ sub make_new_child {
if(-d $ulsdir) {
if (opendir(LSDIR,$ulsdir)) {
while ($ulsfn=readdir(LSDIR)) {
+ undef $obs, $rights;
my @ulsstats=stat($ulsdir.'/'.$ulsfn);
- $ulsout.=$ulsfn.'&'.
- join('&',@ulsstats).':';
+ #We do some obsolete checking here
+ 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);
}
@@ -2538,6 +3141,79 @@ sub make_new_child {
} else {
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
} else {
@@ -2546,20 +3222,20 @@ sub make_new_child {
}
# -------------------------------------------------------------------- complete
alarm(0);
- &status('Listening to '.$clientname);
+ &status('Listening to '.$clientname." ($keymode)");
}
# --------------------------------------------- client unknown or fishy, refuse
} else {
print $client "refused\n";
$client->close();
- &logthis("<font color=blue>WARNING: "
+ &logthis("<font color='blue'>WARNING: "
."Rejected client $clientip, closing connection</font>");
}
}
# =============================================================================
- &logthis("<font color=red>CRITICAL: "
+ &logthis("<font color='red'>CRITICAL: "
."Disconnect from $clientip ($clientname)</font>");
@@ -2584,13 +3260,10 @@ sub make_new_child {
#
sub ManagePermissions
{
- my $request = shift;
- my $domain = shift;
- my $user = shift;
- my $authtype= shift;
+
+ my ($request, $domain, $user, $authtype) = @_;
# See if the request is of the form /$domain/_au
- &logthis("ruequest is $request");
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
my $execdir = $perlvar{'lonDaemons'};
my $userhome= "/home/$user" ;
@@ -2605,8 +3278,8 @@ sub ManagePermissions
#
sub GetAuthType
{
- my $domain = shift;
- my $user = shift;
+
+ my ($domain, $user) = @_;
Debug("GetAuthType( $domain, $user ) \n");
my $proname = &propath($domain, $user);
@@ -2715,17 +3388,36 @@ sub chatadd {
sub unsub {
my ($fname,$clientip)=@_;
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")) {
- $result="ok\n";
- } else {
- $result="not_subscribed\n";
- }
+ $unsubs++; # Successful unsub via marker file.
+ }
+
+ # The more modern way to do it is to have a subscription list
+ # file:
+
if (-e "$fname.subscription") {
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 {
- if ($result != "ok\n") { $result="not_subscribed\n"; }
+ $result = "not_subscribed\n";
}
+
return $result;
}
@@ -2847,6 +3539,16 @@ sub make_passwd_file {
}
} 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";
{
&Debug("Executing external: ".$execpath);
@@ -2879,7 +3581,7 @@ sub sethost {
my (undef,$hostid)=split(/:/,$remotereq);
if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; }
if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) {
- $currenthostid=$hostid;
+ $currenthostid =$hostid;
$currentdomainid=$hostdom{$hostid};
&logthis("Setting hostid to $hostid, and domain to $currentdomainid");
} else {
@@ -2919,6 +3621,7 @@ sub userload {
return $userloadpercent;
}
+
# ----------------------------------- POD (plain old documentation, CPAN style)
=head1 NAME