--- loncom/lond 2004/02/24 16:53:16 1.179
+++ loncom/lond 2004/07/22 23:08:43 1.206
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.179 2004/02/24 16:53:16 albertel Exp $
+# $Id: lond,v 1.206 2004/07/22 23:08:43 raeburn Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -45,25 +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 $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.179 $'; #' stupid emacs
+my $VERSION='$Revision: 1.206 $'; #' 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:
@@ -74,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
@@ -120,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
@@ -175,7 +354,6 @@ sub ReadManagerTable {
while(my $host = <MANAGERS>) {
chomp($host);
if ($host =~ "^#") { # Comment line.
- logthis('<font color="green"> Skipping line: '. "$host</font>\n");
next;
}
if (!defined $hostip{$host}) { # This is a non cluster member
@@ -225,8 +403,8 @@ sub ValidManager {
# 1 - Success.
#
sub CopyFile {
- my $oldfile = shift;
- my $newfile = shift;
+
+ my ($oldfile, $newfile) = @_;
# The file must exist:
@@ -326,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:
@@ -350,6 +528,8 @@ sub InstallFile {
return 1;
}
+
+
#
# ConfigFileFromSelector: converts a configuration file selector
# (one of host or domain at this point) into a
@@ -564,8 +744,8 @@ sub isValidEditCommand {
# file being edited.
#
sub ApplyEdit {
- my $directive = shift;
- my $editor = shift;
+
+ 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
@@ -649,8 +829,8 @@ sub AdjustOurHost {
# editor - Editor containing the file.
#
sub ReplaceConfigFile {
- my $filename = shift;
- my $editor = shift;
+
+ my ($filename, $editor) = @_;
CopyFile ($filename, $filename.".old");
@@ -749,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);
@@ -760,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
@@ -822,7 +1002,7 @@ sub REAPER { # ta
if (defined($children{$pid})) {
&logthis("Child $pid died");
delete($children{$pid});
- } else {
+ } elsif ($pid > 0) {
&logthis("Unknown Child $pid died");
}
} while ( $pid > 0 );
@@ -843,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
}
@@ -853,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)");
@@ -863,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) {
@@ -875,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:
@@ -885,15 +1068,21 @@ 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>) {
if (!($configline =~ /^\s*\#/)) {
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; }
+ $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);
@@ -1015,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");
@@ -1030,13 +1218,14 @@ sub logstatus {
my $docdir=$perlvar{'lonDocRoot'};
{
my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt");
- print $fh $$."\t".$clientname."\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");
@@ -1095,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>');
}
}
@@ -1203,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');
@@ -1258,8 +1447,21 @@ 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.
@@ -1291,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!!
@@ -1309,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, '.
@@ -1316,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
@@ -1355,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>) {
@@ -1552,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));
}
}
@@ -1818,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;
@@ -1852,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
@@ -1863,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";
@@ -1879,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";
}
@@ -1929,11 +2232,14 @@ sub make_new_child {
# ------------------------------------------------------------------------- put
} elsif ($userinput =~ /^put/) {
if(isClient) {
- my ($cmd,$udom,$uname,$namespace,$what)
+ my ($cmd,$udom,$uname,$namespace,$what,@extras)
=split(/:/,$userinput);
$namespace=~s/\//\_/g;
$namespace=~s/\W//g;
if ($namespace ne 'roles') {
+ if (@extras) {
+ $what .= ':'.join(':',@extras);
+ }
chomp($what);
my $proname=propath($udom,$uname);
my $now=time;
@@ -2006,12 +2312,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";
@@ -2484,7 +2790,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;
@@ -2532,8 +2838,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";
@@ -2568,14 +2874,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.'&';
}
}
}
@@ -2729,6 +3040,24 @@ 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) {
@@ -2815,6 +3144,105 @@ 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";
+ }
+#--------------------- read and retrieve institutional code format (for support form).
+ } elsif ($userinput =~/^autoinstcodeformat:/) {
+ if (isClient) {
+ my $reply;
+ my($cmd,$cdom,$course) = split(/:/,$userinput);
+ my @pairs = split/\&/,$course;
+ my %instcodes = ();
+ my %codes = ();
+ my @codetitles = ();
+ my %cat_titles = ();
+ my %cat_order = ();
+ foreach (@pairs) {
+ my ($key,$value) = split/=/,$_;
+ $instcodes{&unescape($key)} = &unescape($value);
+ }
+ my $formatreply = &localenroll::instcode_format($cdom,\%instcodes,\%codes,\@codetitles,\%cat_titles,\%cat_order);
+ if ($formatreply eq 'ok') {
+ my $codes_str = &hash2str(%codes);
+ my $codetitles_str = &array2str(@codetitles);
+ my $cat_titles_str = &hash2str(%cat_titles);
+ my $cat_order_str = &hash2str(%cat_order);
+ print $client $codes_str.':'.$codetitles_str.':'.$cat_titles_str.':'.$cat_order_str."\n";
+ }
+ } else {
+ print $client "refused\n";
+ }
# ------------------------------------------------------------- unknown command
} else {
@@ -2823,20 +3251,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>");
@@ -2861,10 +3289,8 @@ 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
if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput...
@@ -2881,8 +3307,8 @@ sub ManagePermissions
#
sub GetAuthType
{
- my $domain = shift;
- my $user = shift;
+
+ my ($domain, $user) = @_;
Debug("GetAuthType( $domain, $user ) \n");
my $proname = &propath($domain, $user);
@@ -2991,17 +3417,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;
}
@@ -3123,6 +3568,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);
@@ -3155,7 +3610,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 {
@@ -3195,6 +3650,74 @@ sub userload {
return $userloadpercent;
}
+# Routines for serializing arrays and hashes (copies from lonnet)
+
+sub array2str {
+ my (@array) = @_;
+ my $result=&arrayref2str(\@array);
+ $result=~s/^__ARRAY_REF__//;
+ $result=~s/__END_ARRAY_REF__$//;
+ return $result;
+}
+
+sub arrayref2str {
+ my ($arrayref) = @_;
+ my $result='__ARRAY_REF__';
+ foreach my $elem (@$arrayref) {
+ if(ref($elem) eq 'ARRAY') {
+ $result.=&arrayref2str($elem).'&';
+ } elsif(ref($elem) eq 'HASH') {
+ $result.=&hashref2str($elem).'&';
+ } elsif(ref($elem)) {
+ #print("Got a ref of ".(ref($elem))." skipping.");
+ } else {
+ $result.=&escape($elem).'&';
+ }
+ }
+ $result=~s/\&$//;
+ $result .= '__END_ARRAY_REF__';
+ return $result;
+}
+
+sub hash2str {
+ my (%hash) = @_;
+ my $result=&hashref2str(\%hash);
+ $result=~s/^__HASH_REF__//;
+ $result=~s/__END_HASH_REF__$//;
+ return $result;
+}
+
+sub hashref2str {
+ my ($hashref)=@_;
+ my $result='__HASH_REF__';
+ foreach (sort(keys(%$hashref))) {
+ if (ref($_) eq 'ARRAY') {
+ $result.=&arrayref2str($_).'=';
+ } elsif (ref($_) eq 'HASH') {
+ $result.=&hashref2str($_).'=';
+ } elsif (ref($_)) {
+ $result.='=';
+ #print("Got a ref of ".(ref($_))." skipping.");
+ } else {
+ if ($_) {$result.=&escape($_).'=';} else { last; }
+ }
+
+ if(ref($hashref->{$_}) eq 'ARRAY') {
+ $result.=&arrayref2str($hashref->{$_}).'&';
+ } elsif(ref($hashref->{$_}) eq 'HASH') {
+ $result.=&hashref2str($hashref->{$_}).'&';
+ } elsif(ref($hashref->{$_})) {
+ $result.='&';
+ #print("Got a ref of ".(ref($hashref->{$_}))." skipping.");
+ } else {
+ $result.=&escape($hashref->{$_}).'&';
+ }
+ }
+ $result=~s/\&$//;
+ $result .= '__END_HASH_REF__';
+ return $result;
+}
+
# ----------------------------------- POD (plain old documentation, CPAN style)
=head1 NAME