--- loncom/lond 2004/02/17 20:07:25 1.175
+++ loncom/lond 2004/06/18 23:57:17 1.199
@@ -2,7 +2,7 @@
# The LearningOnline Network
# lond "LON Daemon" Server (port "LOND" 5663)
#
-# $Id: lond,v 1.175 2004/02/17 20:07:25 albertel Exp $
+# $Id: lond,v 1.199 2004/06/18 23:57:17 banghart Exp $
#
# Copyright Michigan State University Board of Trustees
#
@@ -45,6 +45,7 @@ use Authen::Krb4;
use Authen::Krb5;
use lib '/home/httpd/lib/perl/';
use localauth;
+use localenroll;
use File::Copy;
use LONCAPA::ConfigFileEdit;
@@ -53,7 +54,7 @@ my $DEBUG = 0; # Non zero to ena
my $status='';
my $lastlog='';
-my $VERSION='$Revision: 1.175 $'; #' stupid emacs
+my $VERSION='$Revision: 1.199 $'; #' stupid emacs
my $remoteVERSION;
my $currenthostid;
my $currentdomainid;
@@ -225,8 +226,8 @@ sub ValidManager {
# 1 - Success.
#
sub CopyFile {
- my $oldfile = shift;
- my $newfile = shift;
+
+ my ($oldfile, $newfile) = @_;
# The file must exist:
@@ -326,8 +327,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:
@@ -564,8 +565,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 +650,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 +750,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 +761,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
@@ -812,7 +813,6 @@ $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;
@@ -822,12 +822,18 @@ sub REAPER { # ta
$pid = waitpid(-1,&WNOHANG());
if (defined($children{$pid})) {
&logthis("Child $pid died");
- $children --;
- delete $children{$pid};
- } else {
+ 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");
}
@@ -838,7 +844,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
}
@@ -848,7 +854,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)");
@@ -882,12 +888,14 @@ sub ReadHostTable {
open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
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;
+ $hostdom{$id}=$domain;
+ $hostip{$id}=$ip;
+ if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
+ }
}
close(CONFIG);
}
@@ -1008,9 +1016,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");
@@ -1088,11 +1095,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>');
}
}
@@ -1196,7 +1203,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');
@@ -1251,15 +1258,24 @@ 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);
+ } else {
+ &logthis("Unable to determine clinetip");
+ $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 {
@@ -1324,18 +1340,18 @@ sub make_new_child {
print $client "ok\n";
} else {
&logthis(
- "<font color=blue>WARNING: $clientip did not reply challenge</font>");
+ "<font color='blue'>WARNING: $clientip did not reply challenge</font>");
&status('No challenge reply '.$clientip);
}
} 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) {
@@ -1349,7 +1365,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>) {
@@ -1546,7 +1562,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));
}
}
@@ -1812,12 +1828,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;
@@ -1846,7 +1871,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
@@ -1857,7 +1912,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";
@@ -1873,7 +1928,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";
}
@@ -2000,12 +2055,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";
@@ -2331,7 +2386,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.'&';
@@ -2479,7 +2533,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;
@@ -2569,7 +2623,7 @@ sub make_new_child {
$qresult.=$key.'='.$descr.'&';
} else {
my $unescapeVal = &unescape($descr);
- if (eval('$unescapeVal=~/$description/i')) {
+ if (eval('$unescapeVal=~/\Q$description\E/i')) {
$qresult.="$key=$descr&";
}
}
@@ -2724,6 +2778,25 @@ 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) {
@@ -2810,6 +2883,78 @@ sub make_new_child {
} else {
print $client "refused\n";
}
+#------------------------------- is auto-enrollment enabled?
+ } elsif ($userinput =~/^autorun/) {
+ if (isClient) {
+ my $outcome = &localenroll::run();
+ print $client "$outcome\n";
+ } else {
+ print $client "0\n";
+ }
+#------------------------------- get official sections (for auto-enrollment).
+ } elsif ($userinput =~/^autogetsections/) {
+ if (isClient) {
+ my ($cmd,$coursecode)=split(/:/,$userinput);
+ my @secs = &localenroll::get_sections($coursecode);
+ 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,$course_id,$owner)=split(/:/,$userinput);
+ my $outcome = &localenroll::new_course($course_id,$owner);
+ 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,$course_id)=split(/:/,$userinput);
+ my $outcome=&localenroll::validate_courseID($course_id);
+ 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)=split(/:/,$userinput);
+ my ($create_passwd,$authchk) = @_;
+ ($authparam,$create_passwd,$authchk) = &localenroll::create_password($authparam);
+ 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 {
@@ -2824,14 +2969,14 @@ sub make_new_child {
} 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>");
@@ -2856,10 +3001,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...
@@ -2876,8 +3019,8 @@ sub ManagePermissions
#
sub GetAuthType
{
- my $domain = shift;
- my $user = shift;
+
+ my ($domain, $user) = @_;
Debug("GetAuthType( $domain, $user ) \n");
my $proname = &propath($domain, $user);
@@ -2986,17 +3129,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;
}
@@ -3118,6 +3280,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);