--- loncom/lond 2003/11/17 09:32:17 1.163 +++ 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.163 2003/11/17 09:32:17 foxr Exp $ +# $Id: lond,v 1.199 2004/06/18 23:57:17 banghart 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,14 +45,16 @@ use Authen::Krb4; use Authen::Krb5; use lib '/home/httpd/lib/perl/'; use localauth; +use localenroll; use File::Copy; +use LONCAPA::ConfigFileEdit; my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; -my $VERSION='$Revision: 1.163 $'; #' stupid emacs +my $VERSION='$Revision: 1.199 $'; #' stupid emacs my $remoteVERSION; my $currenthostid; my $currentdomainid; @@ -162,37 +164,42 @@ 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('No manager table. Nobody can manage!!'); - return; - } - while(my $host = ) { - 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('No manager table. Nobody can manage!!'); + return; + } + while(my $host = ) { + chomp($host); + if ($host =~ "^#") { # Comment line. + logthis(' Skipping line: '. "$host\n"); + 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 = ; - 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(' registering manager '. + "$dnsname as $cluname with $hostip \n"); + } + } else { + logthis(' existing host'." $host\n"); + $managers{$hostip{$host}} = $host; # Use info from cluster tab if clumemeber + } + } } # @@ -219,8 +226,8 @@ sub ValidManager { # 1 - Success. # sub CopyFile { - my $oldfile = shift; - my $newfile = shift; + + my ($oldfile, $newfile) = @_; # The file must exist: @@ -279,42 +286,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 = ; - close PIPE; - - my ($hostname, $has, $address, $ipnew) = split(/ /,$hostinfo); - &logthis(''. - "hostname = $hostname me = $me, name = $name actual ip = $ipnew "); - - if ($hostname eq $name) { # Lookup succeeded.. - &logthis(' look up ok '); - $ip = $ipnew; - } else { - &logthis(' Lookup failed: ' - .$hostname." ne $name "); - } + 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 +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: @@ -356,7 +351,31 @@ 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 +405,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 +499,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(' isValideditCommand checking: '. + "Command = '$command', Key = '$key', Newline = '$newline' \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 .old +# - Writing the new file to .tmp +# - Moving -> +# 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. # @@ -513,7 +749,8 @@ sub catchexception { my ($error)=@_; $SIG{'QUIT'}='DEFAULT'; $SIG{__DIE__}='DEFAULT'; - &logthis("CRITICAL: " + &status("Catching exception"); + &logthis("CRITICAL: " ."ABNORMAL EXIT. Child $$ for server $thisserver died through " ."a crash with this error msg->[$error]"); &logthis('Famous last words: '.$status.' - '.$lastlog); @@ -523,7 +760,8 @@ sub catchexception { } sub timeout { - &logthis("CRITICAL: TIME OUT ".$$.""); + &status("Handling Timeout"); + &logthis("CRITICAL: TIME OUT ".$$.""); &catchexception('Timeout'); } # -------------------------------- Set signal handlers to record abnormal exits @@ -575,37 +813,51 @@ $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; - my $pid = wait; - if (defined($children{$pid})) { - &logthis("Child $pid died"); - $children --; - delete $children{$pid}; - } else { - &logthis("Unknown Child $pid died"); + &status("Handling child death"); + 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"); } sub HUNTSMAN { # signal handler for SIGINT + &status("Killing children (INT)"); local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children kill 'INT' => keys %children; &logthis("Free socket: ".shutdown($server,2)); # free up socket my $execdir=$perlvar{'lonDaemons'}; unlink("$execdir/logs/lond.pid"); - &logthis("CRITICAL: Shutting down"); + &logthis("CRITICAL: Shutting down"); + &status("Done killing children"); exit; # clean up with dignity } sub HUPSMAN { # signal handler for SIGHUP local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children + &status("Killing children for restart (HUP)"); kill 'INT' => keys %children; &logthis("Free socket: ".shutdown($server,2)); # free up socket - &logthis("CRITICAL: Restarting"); + &logthis("CRITICAL: Restarting"); my $execdir=$perlvar{'lonDaemons'}; unlink("$execdir/logs/lond.pid"); + &status("Restarting self (HUP)"); exec("$execdir/lond"); # here we go again } @@ -636,12 +888,14 @@ sub ReadHostTable { open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; while (my $configline=) { - 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); } @@ -667,6 +921,7 @@ sub ReloadApache { # now be honored. # sub UpdateHosts { + &status("Reload hosts.tab"); logthis(' Updating connections '); # # The %children hash has the set of IP's we currently have children @@ -691,10 +946,12 @@ sub UpdateHosts { } } ReloadApache; + &status("Finished reloading hosts.tab"); } sub checkchildren { + &status("Checking on the children (sending signals)"); &initnewstatus(); &logstatus(); &logthis('Going to check on the children'); @@ -709,6 +966,7 @@ sub checkchildren { sleep 5; $SIG{ALRM} = sub { die "timeout" }; $SIG{__DIE__} = 'DEFAULT'; + &status("Checking on the children (waiting for reports)"); foreach (sort keys %children) { unless (-e "$docdir/lon-status/londchld/$_.txt") { eval { @@ -726,6 +984,7 @@ sub checkchildren { } $SIG{ALRM} = 'DEFAULT'; $SIG{__DIE__} = \&catchexception; + &status("Finished checking children"); } # --------------------------------------------------------------------- Logging @@ -757,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"); @@ -768,17 +1026,20 @@ sub Reply { # ------------------------------------------------------------------ Log status sub logstatus { + &status("Doing logging"); 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."\n"; $fh->close(); } + &status("Finished londstatus.txt"); { my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt"); print $fh $status."\n".$lastlog."\n".time; $fh->close(); } + &status("Finished logging"); } sub initnewstatus { @@ -834,11 +1095,11 @@ sub reconlonc { kill USR1 => $loncpid; } else { &logthis( - "CRITICAL: " + "CRITICAL: " ."lonc at pid $loncpid not responding, giving up"); } } else { - &logthis('CRITICAL: lonc not running, giving up'); + &logthis('CRITICAL: lonc not running, giving up'); } } @@ -942,7 +1203,7 @@ my $execdir=$perlvar{'lonDaemons'}; open (PIDSAVE,">$execdir/logs/lond.pid"); print PIDSAVE "$$\n"; close(PIDSAVE); -&logthis("CRITICAL: ---------- Starting ----------"); +&logthis("CRITICAL: ---------- Starting ----------"); &status('Starting'); @@ -966,8 +1227,11 @@ ReadHostTable; # along the connection. while (1) { + &status('Starting accept'); $client = $server->accept() or next; + &status('Accepted '.$client.' off to spawn'); make_new_child($client); + &status('Finished spawning'); } sub make_new_child { @@ -976,6 +1240,7 @@ sub make_new_child { my $sigset; $client = shift; + &status('Starting new child '.$client); &logthis(' Attempting to start child ('.$client. ")"); # block signal for fork @@ -993,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 { @@ -1066,18 +1340,18 @@ sub make_new_child { print $client "ok\n"; } else { &logthis( - "WARNING: $clientip did not reply challenge"); + "WARNING: $clientip did not reply challenge"); &status('No challenge reply '.$clientip); } } else { &logthis( - "WARNING: " + "WARNING: " ."$clientip failed to initialize: >$remotereq< "); &status('No init '.$clientip); } } else { &logthis( - "WARNING: Unknown client $clientip"); + "WARNING: Unknown client $clientip"); &status('Hung up on '.$clientip); } if ($clientok) { @@ -1091,7 +1365,7 @@ sub make_new_child { } &reconlonc("$perlvar{'lonSockDir'}/$id"); } - &logthis("Established connection: $clientname"); + &logthis("Established connection: $clientname"); &status('Will listen to '.$clientname); # ------------------------------------------------------------ Process requests while (my $userinput=<$client>) { @@ -1204,22 +1478,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); @@ -1269,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)); } } @@ -1419,7 +1712,7 @@ sub make_new_child { unless (mkdir($fpnow,0777)) { $fperror="error: ".($!+0) ." mkdir failed while attempting " - ."makeuser\n"; + ."makeuser"; } } } @@ -1535,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; @@ -1569,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 @@ -1580,7 +1912,7 @@ sub make_new_child { if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. $session.'.id')) { while (my $line=) { - if ($line=~/userfile\.$fname\=/) { $reply='ok'; } + if ($line=~ m|userfile\.\Q$fname\E\=|) { $reply='ok'; } } close(ENVIN); print $client $reply."\n"; @@ -1596,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"; } @@ -1723,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"; @@ -2054,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.'&'; @@ -2202,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; @@ -2292,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&"; } } @@ -2447,9 +2778,30 @@ 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.'
'; + } + }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; @@ -2457,9 +2809,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=; + foreach my $obsolete (@obsolete) { + if($obsolete =~ m|()(on)|) { $obs = 1; } + if($obsolete =~ m|()(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); } @@ -2500,6 +2865,7 @@ sub make_new_child { &logthis( "Client $clientip ($clientname) hanging up: $userinput"); print $client "bye\n"; + $client->shutdown(2); # shutdown the socket forcibly. $client->close(); last; @@ -2517,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 { @@ -2531,14 +2969,14 @@ sub make_new_child { } else { print $client "refused\n"; $client->close(); - &logthis("WARNING: " + &logthis("WARNING: " ."Rejected client $clientip, closing connection"); } } # ============================================================================= - &logthis("CRITICAL: " + &logthis("CRITICAL: " ."Disconnect from $clientip ($clientname)"); @@ -2563,13 +3001,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" ; @@ -2584,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); @@ -2694,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; } @@ -2826,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); 500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.