--- loncom/lond 2001/10/23 04:38:45 1.53 +++ loncom/lond 2002/10/03 15:02:22 1.101 @@ -1,6 +1,31 @@ #!/usr/bin/perl # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) +# +# $Id: lond,v 1.101 2002/10/03 15:02:22 www Exp $ +# +# Copyright Michigan State University Board of Trustees +# +# This file is part of the LearningOnline Network with CAPA (LON-CAPA). +# +# 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 +# (at your option) any later version. +# +# LON-CAPA is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with LON-CAPA; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +# +# /home/httpd/html/adm/gpl.txt +# +# http://www.lon-capa.org/ +# # 5/26/99,6/4,6/10,6/11,6/14,6/15,6/26,6/28,6/30, # 7/8,7/9,7/10,7/12,7/17,7/19,9/21, # 10/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16, @@ -10,20 +35,36 @@ # 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer # 12/05 Scott Harrison # 12/05,12/13,12/29 Gerd Kortemeyer +# YEAR=2001 # Jan 01 Scott Harrison # 02/12 Gerd Kortemeyer # 03/15 Scott Harrison # 03/24 Gerd Kortemeyer # 04/02 Scott Harrison # 05/11,05/28,08/30 Gerd Kortemeyer -# 9/30,10/22 Scott Harrison -# +# 9/30,10/22,11/13,11/15,11/16 Scott Harrison +# 11/26,11/27 Gerd Kortemeyer +# 12/20 Scott Harrison +# 12/22 Gerd Kortemeyer +# YEAR=2002 +# 01/20/02,02/05 Gerd Kortemeyer +# 02/05 Guy Albertelli +# 02/07 Scott Harrison +# 02/12 Gerd Kortemeyer +# 02/19 Matthew Hall +# 02/25 Gerd Kortemeyer +# 05/11 Scott Harrison +### + # based on "Perl Cookbook" ISBN 1-56592-243-3 # preforker - server who forks first # runs as a daemon # HUPs # uses IDEA encryption +use lib '/home/httpd/lib/perl/'; +use LONCAPA::Configuration; + use IO::Socket; use IO::File; use Apache::File; @@ -33,9 +74,77 @@ use Crypt::IDEA; use LWP::UserAgent(); use GDBM_File; use Authen::Krb4; +use Authen::Krb5; use lib '/home/httpd/lib/perl/'; use localauth; +my $DEBUG = 0; # Non zero to enable debug log entries. + +my $status=''; +my $lastlog=''; + +# +# The array below are password error strings." +# +my $lastpwderror = 13; # Largest error number from lcpasswd. +my @passwderrors = ("ok", + "lcpasswd must be run as user 'www'", + "lcpasswd got incorrect number of arguments", + "lcpasswd did not get the right nubmer of input text lines", + "lcpasswd too many simultaneous pwd changes in progress", + "lcpasswd User does not exist.", + "lcpasswd Incorrect current passwd", + "lcpasswd Unable to su to root.", + "lcpasswd Cannot set new passwd.", + "lcpasswd Username has invalid characters", + "lcpasswd Invalid characters in password", + "11", "12", + "lcpasswd Password mismatch"); + + +# The array below are lcuseradd error strings.: + +my $lastadderror = 13; +my @adderrors = ("ok", + "User ID mismatch, lcuseradd must run as user www", + "lcuseradd Incorrect number of command line parameters must be 3", + "lcuseradd Incorrect number of stdinput lines, must be 3", + "lcuseradd Too many other simultaneous pwd changes in progress", + "lcuseradd User does not exist", + "lcuseradd Unabel to mak ewww member of users's group", + "lcuseradd Unable to su to root", + "lcuseradd Unable to set password", + "lcuseradd Usrname has invbalid charcters", + "lcuseradd Password has an invalid character", + "lcuseradd User already exists", + "lcuseradd Could not add user.", + "lcuseradd Password mismatch"); + + +# +# Convert an error return code from lcpasswd to a string value. +# +sub lcpasswdstrerror { + my $ErrorCode = shift; + if(($ErrorCode < 0) || ($ErrorCode > $lastpwderror)) { + return "lcpasswd Unrecognized error return value ".$ErrorCode; + } else { + return $passwderrors[$ErrorCode]; + } +} + +# +# Convert an error return code from lcuseradd to a string value: +# +sub lcuseraddstrerror { + my $ErrorCode = shift; + if(($ErrorCode < 0) || ($ErrorCode > $lastadderror)) { + return "lcuseradd - Unrecognized error code: ".$ErrorCode; + } else { + return $adderrors[$ErrorCode]; + } +} + # grabs exception and records it to log before exiting sub catchexception { my ($error)=@_; @@ -44,27 +153,26 @@ sub catchexception { &logthis("CRITICAL: " ."ABNORMAL EXIT. Child $$ for server $wasserver died through " ."a crash with this error msg->[$error]"); + &logthis('Famous last words: '.$status.' - '.$lastlog); if ($client) { print $client "error: $error\n"; } + $server->close(); die($error); } +sub timeout { + &logthis("CRITICAL: TIME OUT ".$$.""); + &catchexception('Timeout'); +} # -------------------------------- Set signal handlers to record abnormal exits $SIG{'QUIT'}=\&catchexception; $SIG{__DIE__}=\&catchexception; -# ------------------------------------ Read httpd access.conf and get variables - -open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf"; - -while ($configline=) { - if ($configline =~ /PerlSetVar/) { - my ($dummy,$varname,$varvalue)=split(/\s+/,$configline); - chomp($varvalue); - $perlvar{$varname}=$varvalue; - } -} -close(CONFIG); +# ---------------------------------- Read loncapa_apache.conf and loncapa.conf +&status("Read loncapa.conf and loncapa_apache.conf"); +my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf'); +my %perlvar=%{$perlvarref}; +undef $perlvarref; # ----------------------------- Make sure this process is running from user=www my $wwwid=getpwnam('www'); @@ -95,7 +203,7 @@ open (CONFIG,"$perlvar{'lonTabDir'}/host while ($configline=) { my ($id,$domain,$role,$name,$ip)=split(/:/,$configline); - chomp($ip); + chomp($ip); $ip=~s/\D+$//; $hostid{$ip}=$id; if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; } $PREFORK++; @@ -114,7 +222,7 @@ $server = IO::Socket::INET->new(LocalPor # global variables -$MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should +$MAX_CLIENTS_PER_CHILD = 50; # number of clients each child should # process %children = (); # keys are current child process IDs $children = 0; # current number of children @@ -122,14 +230,19 @@ $children = 0; # cu sub REAPER { # takes care of dead children $SIG{CHLD} = \&REAPER; my $pid = wait; - $children --; - &logthis("Child $pid died"); - delete $children{$pid}; + if (defined($children{$pid})) { + &logthis("Child $pid died"); + $children --; + delete $children{$pid}; + } else { + &logthis("Unknown Child $pid died"); + } } sub HUNTSMAN { # signal handler for SIGINT 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"); @@ -139,13 +252,39 @@ sub HUNTSMAN { # si sub HUPSMAN { # signal handler for SIGHUP local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children kill 'INT' => keys %children; - close($server); # free up socket + &logthis("Free socket: ".shutdown($server,2)); # free up socket &logthis("CRITICAL: Restarting"); unlink("$execdir/logs/lond.pid"); my $execdir=$perlvar{'lonDaemons'}; exec("$execdir/lond"); # here we go again } +sub checkchildren { + &initnewstatus(); + &logstatus(); + &logthis('Going to check on the children'); + $docdir=$perlvar{'lonDocRoot'}; + foreach (sort keys %children) { + sleep 1; + unless (kill 'USR1' => $_) { + &logthis ('Child '.$_.' is dead'); + &logstatus($$.' is dead'); + } + } + sleep 5; + foreach (sort keys %children) { + unless (-e "$docdir/lon-status/londchld/$_.txt") { + &logthis('Child '.$_.' did not respond'); + kill 9 => $_; + $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; + $subj="LON: $perlvar{'lonHostID'} killed lond process $_"; + my $result=`echo 'Killed lond process $_.' | mailto $emailto -s '$subj' > /dev/null`; + $execdir=$perlvar{'lonDaemons'}; + $result=`/bin/cp $execdir/logs/lond.log $execdir/logs/lond.log.$_` + } + } +} + # --------------------------------------------------------------------- Logging sub logthis { @@ -154,9 +293,54 @@ sub logthis { my $fh=IO::File->new(">>$execdir/logs/lond.log"); my $now=time; my $local=localtime($now); + $lastlog=$local.': '.$message; print $fh "$local ($$): $message\n"; } +# ------------------------- Conditional log if $DEBUG true. +sub Debug { + my $message = shift; + if($DEBUG) { + &logthis($message); + } +} +# ------------------------------------------------------------------ Log status + +sub logstatus { + my $docdir=$perlvar{'lonDocRoot'}; + { + my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); + print $fh $$."\t".$status."\t".$lastlog."\n"; + $fh->close(); + } + { + my $fh=IO::File->new(">$docdir/lon-status/londchld/$$.txt"); + print $fh $status."\n".$lastlog."\n".time; + $fh->close(); + } +} + +sub initnewstatus { + my $docdir=$perlvar{'lonDocRoot'}; + my $fh=IO::File->new(">$docdir/lon-status/londstatus.txt"); + my $now=time; + my $local=localtime($now); + print $fh "LOND status $local - parent $$\n\n"; + opendir(DIR,"$docdir/lon-status/londchld"); + while ($filename=readdir(DIR)) { + unlink("$docdir/lon-status/londchld/$filename"); + } + closedir(DIR); +} + +# -------------------------------------------------------------- Status setting + +sub status { + my $what=shift; + my $now=time; + my $local=localtime($now); + $status=$local.': '.$what; +} # -------------------------------------------------------- Escape Special Chars @@ -186,10 +370,10 @@ sub reconlonc { if (kill 0 => $loncpid) { &logthis("lonc at pid $loncpid responding, sending USR1"); kill USR1 => $loncpid; - sleep 1; + sleep 5; if (-e "$peerfile") { return; } &logthis("$peerfile still not there, give it another try"); - sleep 5; + sleep 10; if (-e "$peerfile") { return; } &logthis( "WARNING: $peerfile still not there, giving up"); @@ -227,6 +411,7 @@ sub reply { if ($answer eq 'con_lost') { $answer=subreply("ping",$server); if ($answer ne $server) { + &logthis("sub reply: answer != server"); &reconlonc("$perlvar{'lonSockDir'}/$server"); } $answer=subreply($cmd,$server); @@ -303,6 +488,7 @@ open (PIDSAVE,">$execdir/logs/lond.pid") print PIDSAVE "$$\n"; close(PIDSAVE); &logthis("CRITICAL: ---------- Starting ----------"); +&status('Starting'); # ------------------------------------------------------- Now we are on our own @@ -313,13 +499,19 @@ for (1 .. $PREFORK) { # ----------------------------------------------------- Install signal handlers +&status('Forked children'); + $SIG{CHLD} = \&REAPER; $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; $SIG{HUP} = \&HUPSMAN; +$SIG{USR1} = \&checkchildren; # And maintain the population. while (1) { + &status('Sleeping'); sleep; # wait for a signal (i.e., child's death) + &logthis('Woke up'); + &status('Woke up'); for ($i = $children; $i < $PREFORK; $i++) { make_new_child(); # top up the child pool } @@ -343,24 +535,35 @@ sub make_new_child { or die "Can't unblock SIGINT for fork: $!\n"; $children{$pid} = 1; $children++; + &status('Started child '.$pid); return; } else { # Child can *not* return from this subroutine. $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before - + $SIG{USR1}= \&logstatus; + $SIG{ALRM}= \&timeout; + $lastlog='Forked '; + $status='Forked'; + # unblock signals sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: $!\n"; $tmpsnum=0; - +#---------------------------------------------------- kerberos 5 initialization + &Authen::Krb5::init_context(); + &Authen::Krb5::init_ets(); + # handle connections until we've reached $MAX_CLIENTS_PER_CHILD for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { + &status('Idle, waiting for connection'); $client = $server->accept() or last; - + &status('Accepted connection'); # ============================================================================= # do something with the connection # ----------------------------------------------------------------------------- + $client->sockopt(SO_KEEPALIVE, 1);# Enable monitoring of + # connection liveness. # see if we know client and check for spoof IP by challenge my $caller=getpeername($client); my ($port,$iaddr)=unpack_sockaddr_in($caller); @@ -369,13 +572,17 @@ sub make_new_child { &logthis( "INFO: Connection $i, $clientip ($hostid{$clientip})" ); + &status("Connecting $clientip ($hostid{$clientip})"); my $clientok; if ($clientrec) { + &status("Waiting for init from $clientip ($hostid{$clientip})"); my $remotereq=<$client>; $remotereq=~s/\W//g; if ($remotereq eq 'init') { my $challenge="$$".time; print $client "$challenge\n"; + &status( + "Waiting for challenge reply from $clientip ($hostid{$clientip})"); $remotereq=<$client>; $remotereq=~s/\W//g; if ($challenge eq $remotereq) { @@ -384,28 +591,33 @@ sub make_new_child { } else { &logthis( "WARNING: $clientip did not reply challenge"); - print $client "bye\n"; + &status('No challenge reply '.$clientip); } } else { &logthis( "WARNING: " ."$clientip failed to initialize: >$remotereq< "); - print $client "bye\n"; + &status('No init '.$clientip); } } else { &logthis( "WARNING: Unknown client $clientip"); - print $client "bye\n"; + &status('Hung up on '.$clientip); } if ($clientok) { # ---------------- New known client connecting, could mean machine online again + &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); &logthis( "Established connection: $hostid{$clientip}"); + &status('Will listen to '.$hostid{$clientip}); # ------------------------------------------------------------ Process requests while (my $userinput=<$client>) { chomp($userinput); + Debug("Request = $userinput\n"); + &status('Processing '.$hostid{$clientip}.': '.$userinput); my $wasenc=0; + alarm(120); # ------------------------------------------------------------ See if encrypted if ($userinput =~ /^enc/) { if ($cipher) { @@ -419,8 +631,9 @@ sub make_new_child { } $userinput=substr($userinput,0,$cmdlength); $wasenc=1; - } } + } + # ------------------------------------------------------------- Normal commands # ------------------------------------------------------------------------ ping if ($userinput =~ /^ping/) { @@ -453,6 +666,20 @@ sub make_new_child { $loadavg =~ s/\s.*//g; my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; print $client "$loadpercent\n"; +# ----------------------------------------------------------------- currentauth + } elsif ($userinput =~ /^currentauth/) { + if ($wasenc==1) { + my ($cmd,$udom,$uname)=split(/:/,$userinput); + my $result = GetAuthType($udom, $uname); + if($result eq "nouser") { + print $client "unknown_user\n"; + } + else { + print $client "$result\n" + } + } else { + print $client "refused\n"; + } # ------------------------------------------------------------------------ auth } elsif ($userinput =~ /^auth/) { if ($wasenc==1) { @@ -468,15 +695,22 @@ sub make_new_child { my ($howpwd,$contentpwd)=split(/:/,$realpasswd); my $pwdcorrect=0; if ($howpwd eq 'internal') { + &Debug("Internal auth"); $pwdcorrect= (crypt($upass,$contentpwd) eq $contentpwd); } elsif ($howpwd eq 'unix') { - $contentpwd=(getpwnam($uname))[1]; - my $pwauth_path="/usr/local/sbin/pwauth"; - unless ($contentpwd eq 'x') { - $pwdcorrect= - (crypt($upass,$contentpwd) eq $contentpwd); - } + &Debug("Unix auth"); + if((getpwnam($uname))[1] eq "") { #no such user! + $pwdcorrect = 0; + } else { + $contentpwd=(getpwnam($uname))[1]; + my $pwauth_path="/usr/local/sbin/pwauth"; + unless ($contentpwd eq 'x') { + $pwdcorrect= + (crypt($upass,$contentpwd) eq + $contentpwd); + } + elsif (-e $pwauth_path) { open PWAUTH, "|$pwauth_path" or die "Cannot invoke authentication"; @@ -484,11 +718,32 @@ sub make_new_child { close PWAUTH; $pwdcorrect=!$?; } + } } elsif ($howpwd eq 'krb4') { + $null=pack("C",0); + unless ($upass=~/$null/) { $pwdcorrect=( Authen::Krb4::get_pw_in_tkt($uname,"", $contentpwd,'krbtgt',$contentpwd,1, $upass) == 0); + } else { $pwdcorrect=0; } + } elsif ($howpwd eq 'krb5') { + $null=pack("C",0); + unless ($upass=~/$null/) { + my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); + my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; + my $krbserver=&Authen::Krb5::parse_name($krbservice); + my $credentials=&Authen::Krb5::cc_default(); + $credentials->initialize($krbclient); + my $krbreturn = + &Authen::Krb5::get_in_tkt_with_password( + $krbclient,$krbserver,$upass,$credentials); +# unless ($krbreturn) { +# &logthis("Krb5 Error: ". +# &Authen::Krb5::error()); +# } + $pwdcorrect = ($krbreturn == 1); + } else { $pwdcorrect=0; } } elsif ($howpwd eq 'localauth') { $pwdcorrect=&localauth::localauth($uname,$upass, $contentpwd); @@ -512,7 +767,8 @@ sub make_new_child { chomp($npass); $upass=&unescape($upass); $npass=&unescape($npass); - my $proname=propath($udom,$uname); + &Debug("Trying to change password for $uname"); + my $proname=propath($udom,$uname); my $passfilename="$proname/passwd"; if (-e $passfilename) { my $realpasswd; @@ -521,17 +777,54 @@ sub make_new_child { chomp($realpasswd); my ($howpwd,$contentpwd)=split(/:/,$realpasswd); if ($howpwd eq 'internal') { + &Debug("internal auth"); if (crypt($upass,$contentpwd) eq $contentpwd) { my $salt=time; $salt=substr($salt,6,2); my $ncpass=crypt($npass,$salt); { my $pf = IO::File->new(">$passfilename"); print $pf "internal:$ncpass\n"; } + &logthis("Result of password change for $uname: pwchange_success"); print $client "ok\n"; } else { print $client "non_authorized\n"; } - } else { + } elsif ($howpwd eq 'unix') { + # Unix means we have to access /etc/password + # one way or another. + # First: Make sure the current password is + # correct + &Debug("auth is unix"); + $contentpwd=(getpwnam($uname))[1]; + my $pwdcorrect = "0"; + my $pwauth_path="/usr/local/sbin/pwauth"; + unless ($contentpwd eq 'x') { + $pwdcorrect= + (crypt($upass,$contentpwd) eq $contentpwd); + } elsif (-e $pwauth_path) { + open PWAUTH, "|$pwauth_path" or + die "Cannot invoke authentication"; + print PWAUTH "$uname\n$upass\n"; + close PWAUTH; + &Debug("exited pwauth with $? ($uname,$upass) "); + $pwdcorrect=($? == 0); + } + if ($pwdcorrect) { + my $execdir=$perlvar{'lonDaemons'}; + &Debug("Opening lcpasswd pipeline"); + my $pf = IO::File->new("|$execdir/lcpasswd > /home/www/lcpasswd.log"); + print $pf "$uname\n$npass\n$npass\n"; + close $pf; + my $err = $?; + my $result = ($err>0 ? 'pwchange_failure' + : 'ok'); + &logthis("Result of password change for $uname: ". + &lcpasswdstrerror($?)); + print $client "$result\n"; + } else { + print $client "non_authorized\n"; + } + } else { print $client "auth_mode_error\n"; } } else { @@ -542,13 +835,19 @@ sub make_new_child { } # -------------------------------------------------------------------- makeuser } elsif ($userinput =~ /^makeuser/) { + &Debug("Make user received"); + my $oldumask=umask(0077); if ($wasenc==1) { my ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); + &Debug("cmd =".$cmd." $udom =".$udom. + " uname=".$uname); chomp($npass); $npass=&unescape($npass); my $proname=propath($udom,$uname); my $passfilename="$proname/passwd"; + &Debug("Password file created will be:". + $passfilename); if (-e $passfilename) { print $client "already_exists\n"; } elsif ($udom ne $perlvar{'lonDefDomain'}) { @@ -561,52 +860,14 @@ sub make_new_child { $fpnow.='/'.$fpparts[$i]; unless (-e $fpnow) { unless (mkdir($fpnow,0777)) { - $fperror="error:$!\n"; + $fperror="error:$!"; } } } unless ($fperror) { - if ($umode eq 'krb4') { - { - my $pf = IO::File->new(">$passfilename"); - print $pf "krb4:$npass\n"; - } - print $client "ok\n"; - } elsif ($umode eq 'internal') { - my $salt=time; - $salt=substr($salt,6,2); - my $ncpass=crypt($npass,$salt); - { - my $pf = IO::File->new(">$passfilename"); - print $pf "internal:$ncpass\n"; - } - print $client "ok\n"; - } elsif ($umode eq 'localauth') { - { - my $pf = IO::File->new(">$passfilename"); - print $pf "localauth:$npass\n"; - } - print $client "ok\n"; - } elsif ($umode eq 'unix') { - { - my $execpath="$perlvar{'lonDaemons'}/". - "lcuseradd"; - my $se = IO::File->new("|$execpath"); - print $se "$uname\n"; - print $se "$npass\n"; - print $se "$npass\n"; - my $pf = IO::File->new(">$passfilename"); - print $pf "unix:\n"; - } - } elsif ($umode eq 'none') { - { - my $pf = IO::File->new(">$passfilename"); - print $pf "none:\n"; - } - print $client "ok\n"; - } else { - print $client "auth_mode_error\n"; - } + my $result=&make_passwd_file($uname, $umode,$npass, + $passfilename); + print $client $result; } else { print $client "$fperror\n"; } @@ -614,6 +875,29 @@ sub make_new_child { } else { print $client "refused\n"; } + umask($oldumask); +# -------------------------------------------------------------- changeuserauth + } elsif ($userinput =~ /^changeuserauth/) { + &Debug("Changing authorization"); + if ($wasenc==1) { + my + ($cmd,$udom,$uname,$umode,$npass)=split(/:/,$userinput); + chomp($npass); + &Debug("cmd = ".$cmd." domain= ".$udom. + "uname =".$uname." umode= ".$umode); + $npass=&unescape($npass); + my $proname=&propath($udom,$uname); + my $passfilename="$proname/passwd"; + if ($udom ne $perlvar{'lonDefDomain'}) { + print $client "not_right_domain\n"; + } else { + my $result=&make_passwd_file($uname, $umode,$npass, + $passfilename); + print $client $result; + } + } else { + print $client "refused\n"; + } # ------------------------------------------------------------------------ home } elsif ($userinput =~ /^home/) { my ($cmd,$udom,$uname)=split(/:/,$userinput); @@ -676,48 +960,61 @@ sub make_new_child { } else { print $client "rejected\n"; } +# -------------------------------------- fetch a user file from a remote server + } elsif ($userinput =~ /^fetchuserfile/) { + my ($cmd,$fname)=split(/:/,$userinput); + my ($udom,$uname,$ufile)=split(/\//,$fname); + my $udir=propath($udom,$uname).'/userfiles'; + unless (-e $udir) { mkdir($udir,0770); } + if (-e $udir) { + $ufile=~s/^[\.\~]+//; + $ufile=~s/\///g; + my $transname=$udir.'/'.$ufile; + my $remoteurl='http://'.$clientip.'/userfiles/'.$fname; + my $response; + { + my $ua=new LWP::UserAgent; + my $request=new HTTP::Request('GET',"$remoteurl"); + $response=$ua->request($request,$transname); + } + if ($response->is_error()) { + unlink($transname); + my $message=$response->status_line; + &logthis( + "LWP GET: $message for $fname ($remoteurl)"); + print $client "failed\n"; + } else { + print $client "ok\n"; + } + } else { + print $client "not_home\n"; + } +# ------------------------------------------ authenticate access to a user file + } elsif ($userinput =~ /^tokenauthuserfile/) { + my ($cmd,$fname,$session)=split(/:/,$userinput); + chomp($session); + $reply='non_auth'; + if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. + $session.'.id')) { + while ($line=) { + if ($line=~/userfile\.$fname\=/) { $reply='ok'; } + } + close(ENVIN); + print $client $reply."\n"; + } else { + print $client "invalid_token\n"; + } # ----------------------------------------------------------------- unsubscribe } elsif ($userinput =~ /^unsub/) { my ($cmd,$fname)=split(/:/,$userinput); if (-e $fname) { - if (unlink("$fname.$hostid{$clientip}")) { - print $client "ok\n"; - } else { - print $client "not_subscribed\n"; - } + print $client &unsub($client,$fname,$clientip); } else { print $client "not_found\n"; } # ------------------------------------------------------------------- subscribe } elsif ($userinput =~ /^sub/) { - my ($cmd,$fname)=split(/:/,$userinput); - my $ownership=ishome($fname); - if ($ownership eq 'owner') { - if (-e $fname) { - if (-d $fname) { - print $client "directory\n"; - } else { - $now=time; - { - my $sh; - if ($sh= - IO::File->new(">$fname.$hostid{$clientip}")) { - print $sh "$clientip:$now\n"; - } - } - unless ($fname=~/\.meta$/) { - unlink("$fname.meta.$hostid{$clientip}"); - } - $fname=~s/\/home\/httpd\/html\/res/raw/; - $fname="http://$thisserver/".$fname; - print $client "$fname\n"; - } - } else { - print $client "not_found\n"; - } - } else { - print $client "rejected\n"; - } + print $client &subscribe($userinput,$clientip); # ------------------------------------------------------------------------- log } elsif ($userinput =~ /^log/) { my ($cmd,$udom,$uname,$what)=split(/:/,$userinput); @@ -768,9 +1065,13 @@ sub make_new_child { } # -------------------------------------------------------------------- rolesput } elsif ($userinput =~ /^rolesput/) { + &Debug("rolesput"); if ($wasenc==1) { my ($cmd,$exedom,$exeuser,$udom,$uname,$what) =split(/:/,$userinput); + &Debug("cmd = ".$cmd." exedom= ".$exedom. + "user = ".$exeuser." udom=".$udom. + "what = ".$what); my $namespace='roles'; chomp($what); my $proname=propath($udom,$uname); @@ -787,7 +1088,11 @@ sub make_new_child { if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { foreach $pair (@pairs) { ($key,$value)=split(/=/,$pair); + &ManagePermissions($key, $udom, $uname, + &GetAuthType( $udom, + $uname)); $hash{$key}=$value; + } if (untie(%hash)) { print $client "ok\n"; @@ -910,21 +1215,34 @@ sub make_new_child { } # ------------------------------------------------------------------------ dump } elsif ($userinput =~ /^dump/) { - my ($cmd,$udom,$uname,$namespace) + my ($cmd,$udom,$uname,$namespace,$regexp) =split(/:/,$userinput); $namespace=~s/\//\_/g; $namespace=~s/\W//g; - my $proname=propath($udom,$uname); + if (defined($regexp)) { + $regexp=&unescape($regexp); + } else { + $regexp='.'; + } my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { - foreach $key (keys %hash) { - $qresult.="$key=$hash{$key}&"; + my $proname=propath($udom,$uname); + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + study($regexp); + while (($key,$value) = each(%hash)) { + if ($regexp eq '.') { + $qresult.=$key.'='.$value.'&'; + } else { + my $unescapeKey = &unescape($key); + if (eval('$unescapeKey=~/$regexp/')) { + $qresult.="$key=$value&"; + } + } } - if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; + if (untie(%hash)) { + chop($qresult); + print $client "$qresult\n"; } else { - print $client "error:$!\n"; + print $client "error:$!\n"; } } else { print $client "error:$!\n"; @@ -1003,20 +1321,28 @@ sub make_new_child { } else { print $client "error:$!\n"; } +# -------------------------------------------------------------------- chatsend + } elsif ($userinput =~ /^chatsend/) { + my ($cmd,$cdom,$cnum,$newpost)=split(/\:/,$userinput); + &chatadd($cdom,$cnum,$newpost); + print $client "ok\n"; +# -------------------------------------------------------------------- chatretr + } elsif ($userinput =~ /^chatretr/) { + my ($cmd,$cdom,$cnum)=split(/\:/,$userinput); + my $reply=''; + foreach (&getchat($cdom,$cnum)) { + $reply.=&escape($_).':'; + } + $reply=~s/\:$//; + print $client $reply."\n"; # ------------------------------------------------------------------- querysend } elsif ($userinput =~ /^querysend/) { my ($cmd,$query, - $custom,$customshow)=split(/:/,$userinput); + $arg1,$arg2,$arg3)=split(/\:/,$userinput); $query=~s/\n*$//g; - unless ($custom or $customshow) { - print $client "". - sqlreply("$hostid{$clientip}\&$query")."\n"; - } - else { - print $client "". + print $client "". sqlreply("$hostid{$clientip}\&$query". - "\&$custom"."\&$customshow")."\n"; - } + "\&$arg1"."\&$arg2"."\&$arg3")."\n"; # ------------------------------------------------------------------ queryreply } elsif ($userinput =~ /^queryreply/) { my ($cmd,$id,$reply)=split(/:/,$userinput); @@ -1122,14 +1448,20 @@ sub make_new_child { my $ulsout=''; my $ulsfn; if (-e $ulsdir) { - if (opendir(LSDIR,$ulsdir)) { - while ($ulsfn=readdir(LSDIR)) { - my @ulsstats=stat($ulsdir.'/'.$ulsfn); - $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; - } - closedir(LSDIR); - } - } else { + if(-d $ulsdir) { + if (opendir(LSDIR,$ulsdir)) { + while ($ulsfn=readdir(LSDIR)) { + my @ulsstats=stat($ulsdir.'/'.$ulsfn); + $ulsout.=$ulsfn.'&'. + join('&',@ulsstats).':'; + } + closedir(LSDIR); + } + } else { + my @ulsstats=stat($ulsdir); + $ulsout.=$ulsfn.'&'.join('&',@ulsstats).':'; + } + } else { $ulsout='no_such_dir'; } if ($ulsout eq '') { $ulsout='empty'; } @@ -1140,26 +1472,34 @@ sub make_new_child { &logthis( "Client $clientip ($hostid{$clientip}) hanging up: $userinput"); print $client "bye\n"; + $client->close(); last; # ------------------------------------------------------------- unknown command } else { # unknown command print $client "unknown_cmd\n"; } -# ------------------------------------------------------ client unknown, refuse +# -------------------------------------------------------------------- complete + alarm(0); + &status('Listening to '.$hostid{$clientip}); } +# --------------------------------------------- client unknown or fishy, refuse } else { print $client "refused\n"; + $client->close(); &logthis("WARNING: " ."Rejected client $clientip, closing connection"); - } - &logthis("CRITICAL: " - ."Disconnect from $clientip ($hostid{$clientip})"); + } + } + # ============================================================================= - } - + + &logthis("CRITICAL: " + ."Disconnect from $clientip ($hostid{$clientip})"); # tidy up gracefully and finish + $server->close(); + # this exit is VERY important, otherwise the child will become # a producer of more and more children, forking yourself into # process death. @@ -1168,6 +1508,587 @@ sub make_new_child { } +# +# Checks to see if the input roleput request was to set +# an author role. If so, invokes the lchtmldir script to set +# up a correct public_html +# Parameters: +# request - The request sent to the rolesput subchunk. +# We're looking for /domain/_au +# domain - The domain in which the user is having roles doctored. +# user - Name of the user for which the role is being put. +# authtype - The authentication type associated with the user. +# +sub ManagePermissions +{ + my $request = shift; + my $domain = shift; + my $user = shift; + my $authtype= shift; + + # See if the request is of the form /$domain/_au + + if($request =~ /^(\/$domain\/_au)$/) { # It's an author rolesput... + my $execdir = $perlvar{'lonDaemons'}; + my $userhome= "/home/$user" ; + Debug("system $execdir/lchtmldir $userhome $system $authtype"); + system("$execdir/lchtmldir $userhome $user $authtype"); + } +} +# +# GetAuthType - Determines the authorization type of a user in a domain. + +# Returns the authorization type or nouser if there is no such user. +# +sub GetAuthType +{ + my $domain = shift; + my $user = shift; + + Debug("GetAuthType( $domain, $user ) \n"); + my $proname = &propath($domain, $user); + my $passwdfile = "$proname/passwd"; + if( -e $passwdfile ) { + my $pf = IO::File->new($passwdfile); + my $realpassword = <$pf>; + chomp($realpassword); + Debug("Password info = $realpassword\n"); + my ($authtype, $contentpwd) = split(/:/, $realpassword); + Debug("Authtype = $authtype, content = $contentpwd\n"); + my $availinfo = ''; + if($authtype eq 'krb4' or $authtype eq 'krb5') { + $availinfo = $contentpwd; + } + + return "$authtype:$availinfo"; + } + else { + Debug("Returning nouser"); + return "nouser"; + } +} + +sub addline { + my ($fname,$hostid,$ip,$newline)=@_; + my $contents; + my $found=0; + my $expr='^'.$hostid.':'.$ip.':'; + $expr =~ s/\./\\\./g; + if ($sh=IO::File->new("$fname.subscription")) { + while (my $subline=<$sh>) { + if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} + } + $sh->close(); + } + $sh=IO::File->new(">$fname.subscription"); + if ($contents) { print $sh $contents; } + if ($newline) { print $sh $newline; } + $sh->close(); + return $found; +} + +sub getchat { + my ($cdom,$cname)=@_; + my %hash; + my $proname=&propath($cdom,$cname); + my @entries=(); + if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", + &GDBM_READER(),0640)) { + @entries=map { $_.':'.$hash{$_} } sort keys %hash; + untie %hash; + } + return @entries; +} + +sub chatadd { + my ($cdom,$cname,$newchat)=@_; + my %hash; + my $proname=&propath($cdom,$cname); + my @entries=(); + if (tie(%hash,'GDBM_File',"$proname/nohist_chatroom.db", + &GDBM_WRCREAT(),0640)) { + @entries=map { $_.':'.$hash{$_} } sort keys %hash; + my $time=time; + my ($lastid)=($entries[$#entries]=~/^(\w+)\:/); + my ($thentime,$idnum)=split(/\_/,$lastid); + my $newid=$time.'_000000'; + if ($thentime==$time) { + $idnum=~s/^0+//; + $idnum++; + $idnum=substr('000000'.$idnum,-6,6); + $newid=$time.'_'.$idnum; + } + $hash{$newid}=$newchat; + my $expired=$time-3600; + foreach (keys %hash) { + my ($thistime)=($_=~/(\d+)\_/); + if ($thistime<$expired) { + delete $hash{$_}; + } + } + untie %hash; + } +} + +sub unsub { + my ($fname,$clientip)=@_; + my $result; + if (unlink("$fname.$hostid{$clientip}")) { + $result="ok\n"; + } else { + $result="not_subscribed\n"; + } + if (-e "$fname.subscription") { + my $found=&addline($fname,$hostid{$clientip},$clientip,''); + if ($found) { $result="ok\n"; } + } else { + if ($result != "ok\n") { $result="not_subscribed\n"; } + } + return $result; +} + +sub currentversion { + my $fname=shift; + my $version=-1; + my $ulsdir=''; + if ($fname=~/^(.+)\/[^\/]+$/) { + $ulsdir=$1; + } + $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; + $fname=~s/\.(\w+)$/\.\(\\d\+\)\.$1\$/; + if (-e $fname) { $version=1; } + if (-e $ulsdir) { + if(-d $ulsdir) { + if (opendir(LSDIR,$ulsdir)) { + while ($ulsfn=readdir(LSDIR)) { +# see if this is a regular file (ignore links produced earlier) + my $thisfile=$ulsdir.'/'.$ulsfn; + unless (-l $thisfile) { + if ($thisfile=~/$fname/) { + if ($1>$version) { $version=$1; } + } + } + } + closedir(LSDIR); + $version++; + } + } + } + return $version; +} + +sub thisversion { + my $fname=shift; + my $version=-1; + if ($fname=~/\.(\d+)\.\w+(?:\.meta)*$/) { + $version=$1; + } + return $version; +} + +sub subscribe { + my ($userinput,$clientip)=@_; + my $result; + my ($cmd,$fname)=split(/:/,$userinput); + my $ownership=&ishome($fname); + if ($ownership eq 'owner') { +# explitly asking for the current version? + unless (-e $fname) { + my $currentversion=¤tversion($fname); + if (&thisversion($fname)==$currentversion) { + if ($fname=~/^(.+)\.\d+\.(\w+(?:\.meta)*)$/) { + my $root=$1; + my $extension=$2; + symlink($root.'.'.$extension, + $root.'.'.$currentversion.'.'.$extension); + } + } + } + if (-e $fname) { + if (-d $fname) { + $result="directory\n"; + } else { + if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);} + $now=time; + my $found=&addline($fname,$hostid{$clientip},$clientip, + "$hostid{$clientip}:$clientip:$now\n"); + if ($found) { $result="$fname\n"; } + # if they were subscribed to only meta data, delete that + # subscription, when you subscribe to a file you also get + # the metadata + unless ($fname=~/\.meta$/) { &unsub("$fname.meta",$clientip); } + $fname=~s/\/home\/httpd\/html\/res/raw/; + $fname="http://$thisserver/".$fname; + $result="$fname\n"; + } + } else { + $result="not_found\n"; + } + } else { + $result="rejected\n"; + } + return $result; +} + +sub make_passwd_file { + my ($uname, $umode,$npass,$passfilename)=@_; + my $result="ok\n"; + if ($umode eq 'krb4' or $umode eq 'krb5') { + { + my $pf = IO::File->new(">$passfilename"); + print $pf "$umode:$npass\n"; + } + } elsif ($umode eq 'internal') { + my $salt=time; + $salt=substr($salt,6,2); + my $ncpass=crypt($npass,$salt); + { + &Debug("Creating internal auth"); + my $pf = IO::File->new(">$passfilename"); + print $pf "internal:$ncpass\n"; + } + } elsif ($umode eq 'localauth') { + { + my $pf = IO::File->new(">$passfilename"); + print $pf "localauth:$npass\n"; + } + } elsif ($umode eq 'unix') { + { + my $execpath="$perlvar{'lonDaemons'}/"."lcuseradd"; + { + &Debug("Executing external: ".$execpath); + &Debug("user = ".$uname.", Password =". $npass); + my $se = IO::File->new("|$execpath > /home/www/lcuseradd.log"); + print $se "$uname\n"; + print $se "$npass\n"; + print $se "$npass\n"; + } + my $useraddok = $?; + if($useraddok > 0) { + &logthis("Failed lcuseradd: ".&lcuseraddstrerror($useraddok)); + } + my $pf = IO::File->new(">$passfilename"); + print $pf "unix:\n"; + } + } elsif ($umode eq 'none') { + { + my $pf = IO::File->new(">$passfilename"); + print $pf "none:\n"; + } + } else { + $result="auth_mode_error\n"; + } + return $result; +} + +# ----------------------------------- POD (plain old documentation, CPAN style) + +=head1 NAME + +lond - "LON Daemon" Server (port "LOND" 5663) + +=head1 SYNOPSIS + +Usage: B + +Should only be run as user=www. This is a command-line script which +is invoked by B. There is no expectation that a typical user +will manually start B from the command-line. (In other words, +DO NOT START B YOURSELF.) + +=head1 DESCRIPTION + +There are two characteristics associated with the running of B, +PROCESS MANAGEMENT (starting, stopping, handling child processes) +and SERVER-SIDE ACTIVITIES (password authentication, user creation, +subscriptions, etc). These are described in two large +sections below. + +B + +Preforker - server who forks first. Runs as a daemon. HUPs. +Uses IDEA encryption + +B forks off children processes that correspond to the other servers +in the network. Management of these processes can be done at the +parent process level or the child process level. + +B is the location of log messages. + +The process management is now explained in terms of linux shell commands, +subroutines internal to this code, and signal assignments: + +=over 4 + +=item * + +PID is stored in B + +This is the process id number of the parent B process. + +=item * + +SIGTERM and SIGINT + +Parent signal assignment: + $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; + +Child signal assignment: + $SIG{INT} = 'DEFAULT'; (and SIGTERM is DEFAULT also) +(The child dies and a SIGALRM is sent to parent, awaking parent from slumber + to restart a new child.) + +Command-line invocations: + B B<-s> SIGTERM I + B B<-s> SIGINT I + +Subroutine B: + This is only invoked for the B parent I. +This kills all the children, and then the parent. +The B file is cleared. + +=item * + +SIGHUP + +Current bug: + This signal can only be processed the first time +on the parent process. Subsequent SIGHUP signals +have no effect. + +Parent signal assignment: + $SIG{HUP} = \&HUPSMAN; + +Child signal assignment: + none (nothing happens) + +Command-line invocations: + B B<-s> SIGHUP I + +Subroutine B: + This is only invoked for the B parent I, +This kills all the children, and then the parent. +The B file is cleared. + +=item * + +SIGUSR1 + +Parent signal assignment: + $SIG{USR1} = \&USRMAN; + +Child signal assignment: + $SIG{USR1}= \&logstatus; + +Command-line invocations: + B B<-s> SIGUSR1 I + +Subroutine B: + When invoked for the B parent I, +SIGUSR1 is sent to all the children, and the status of +each connection is logged. + +=item * + +SIGCHLD + +Parent signal assignment: + $SIG{CHLD} = \&REAPER; + +Child signal assignment: + none + +Command-line invocations: + B B<-s> SIGCHLD I + +Subroutine B: + This is only invoked for the B parent I. +Information pertaining to the child is removed. +The socket port is cleaned up. + +=back + +B + +Server-side information can be accepted in an encrypted or non-encrypted +method. + +=over 4 + +=item ping + +Query a client in the hosts.tab table; "Are you there?" + +=item pong + +Respond to a ping query. + +=item ekey + +Read in encrypted key, make cipher. Respond with a buildkey. + +=item load + +Respond with CPU load based on a computation upon /proc/loadavg. + +=item currentauth + +Reply with current authentication information (only over an +encrypted channel). + +=item auth + +Only over an encrypted channel, reply as to whether a user's +authentication information can be validated. + +=item passwd + +Allow for a password to be set. + +=item makeuser + +Make a user. + +=item passwd + +Allow for authentication mechanism and password to be changed. + +=item home + +Respond to a question "are you the home for a given user?" + +=item update + +Update contents of a subscribed resource. + +=item unsubscribe + +The server is unsubscribing from a resource. + +=item subscribe + +The server is subscribing to a resource. + +=item log + +Place in B + +=item put + +stores hash in namespace + +=item rolesput + +put a role into a user's environment + +=item get + +returns hash with keys from array +reference filled in from namespace + +=item eget + +returns hash with keys from array +reference filled in from namesp (encrypts the return communication) + +=item rolesget + +get a role from a user's environment + +=item del + +deletes keys out of array from namespace + +=item keys + +returns namespace keys + +=item dump + +dumps the complete (or key matching regexp) namespace into a hash + +=item store + +stores hash permanently +for this url; hashref needs to be given and should be a \%hashname; the +remaining args aren't required and if they aren't passed or are '' they will +be derived from the ENV + +=item restore + +returns a hash for a given url + +=item querysend + +Tells client about the lonsql process that has been launched in response +to a sent query. + +=item queryreply + +Accept information from lonsql and make appropriate storage in temporary +file space. + +=item idput + +Defines usernames as corresponding to IDs. (These "IDs" are unique identifiers +for each student, defined perhaps by the institutional Registrar.) + +=item idget + +Returns usernames corresponding to IDs. (These "IDs" are unique identifiers +for each student, defined perhaps by the institutional Registrar.) + +=item tmpput + +Accept and store information in temporary space. + +=item tmpget + +Send along temporarily stored information. + +=item ls + +List part of a user's directory. + +=item Hanging up (exit or init) + +What to do when a client tells the server that they (the client) +are leaving the network. + +=item unknown command + +If B is sent an unknown command (not in the list above), +it replys to the client "unknown_cmd". + +=item UNKNOWN CLIENT + +If the anti-spoofing algorithm cannot verify the client, +the client is rejected (with a "refused" message sent +to the client, and the connection is closed. + +=back + +=head1 PREREQUISITES + +IO::Socket +IO::File +Apache::File +Symbol +POSIX +Crypt::IDEA +LWP::UserAgent() +GDBM_File +Authen::Krb4 +Authen::Krb5 + +=head1 COREQUISITES + +=head1 OSNAMES + +linux +=head1 SCRIPT CATEGORIES +Server/Process +=cut 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.