--- loncom/lond 2003/03/04 22:32:20 1.111 +++ loncom/lond 2003/09/16 10:13:20 1.145 @@ -2,7 +2,7 @@ # The LearningOnline Network # lond "LON Daemon" Server (port "LOND" 5663) # -# $Id: lond,v 1.111 2003/03/04 22:32:20 matthew Exp $ +# $Id: lond,v 1.145 2003/09/16 10:13:20 foxr Exp $ # # Copyright Michigan State University Board of Trustees # @@ -50,15 +50,44 @@ # population). Since the time averaged connection rate is close to zero # because lonc's purpose is to maintain near continuous connnections, # preforking is not really needed. -### +# 08/xx/2003 Ron Fox: Add management requests. Management requests +# will be validated via a call to ValidateManager. At present, this +# is done by simple host verification. In the future we can modify +# this function to do a certificate check. +# Management functions supported include: +# - pushing /home/httpd/lonTabs/hosts.tab +# - pushing /home/httpd/lonTabs/domain.tab +# 09/08/2003 Ron Fox: Told lond to take care of change logging so we +# don't have to remember it: +# $Log: lond,v $ +# Revision 1.145 2003/09/16 10:13:20 foxr +# Added ReinitProcess function to oversee the parsing and processing of the +# reinit: client request. +# +# Revision 1.144 2003/09/16 09:47:01 foxr +# Added skeletal support for SIGUSR2 (update hosts.tab) +# +# Revision 1.143 2003/09/15 10:03:52 foxr +# Completed and tested code for pushfile. +# +# Revision 1.142 2003/09/09 20:47:46 www +# Permanently store chatroom entries in chatroom.log +# +# Revision 1.141 2003/09/08 10:32:07 foxr +# Added PushFile sub This sub oversees the push of a new configuration table file +# Currently supported files are: +# - hosts.tab (transaction pushfile:hosts:contents) +# - domain.tab (transaction pushfile:domain:contents) +# +use strict; use lib '/home/httpd/lib/perl/'; use LONCAPA::Configuration; use IO::Socket; use IO::File; -use Apache::File; +#use Apache::File; use Symbol; use POSIX; use Crypt::IDEA; @@ -68,12 +97,29 @@ use Authen::Krb4; use Authen::Krb5; use lib '/home/httpd/lib/perl/'; use localauth; +use File::Copy; my $DEBUG = 0; # Non zero to enable debug log entries. my $status=''; my $lastlog=''; +my $VERSION='$Revision: 1.145 $'; #' stupid emacs +my $remoteVERSION; +my $currenthostid; +my $currentdomainid; + +my $client; +my $clientip; + +my $server; +my $thisserver; + +my %hostid; +my %hostdom; +my %hostip; +my %perlvar; # Will have the apache conf defined perl vars. + # # The array below are password error strings." # @@ -113,6 +159,227 @@ my @adderrors = ("ok", # +# GetCertificate: Given a transaction that requires a certificate, +# this function will extract the certificate from the transaction +# request. Note that at this point, the only concept of a certificate +# is the hostname to which we are connected. +# +# Parameter: +# request - The request sent by our client (this parameterization may +# need to change when we really use a certificate granting +# authority. +# +sub GetCertificate { + my $request = shift; + + return $clientip; +} + + +# +# ValidManager: Determines if a given certificate represents a valid manager. +# in this primitive implementation, the 'certificate' is +# just the connecting loncapa client name. This is checked +# against a valid client list in the configuration. +# +# +sub ValidManager { + my $certificate = shift; + + my $hostentry = $hostid{$certificate}; + if ($hostentry ne undef) { + &logthis('Authenticating manager'. + " $hostentry"); + return 1; + } else { + &logthis(' Failed manager authentication '. + "$certificate "); + } +} +# +# CopyFile: Called as part of the process of installing a +# new configuration file. This function copies an existing +# file to a backup file. +# Parameters: +# oldfile - Name of the file to backup. +# newfile - Name of the backup file. +# Return: +# 0 - Failure (errno has failure reason). +# 1 - Success. +# +sub CopyFile { + my $oldfile = shift; + my $newfile = shift; + + # The file must exist: + + if(-e $oldfile) { + + # Read the old file. + + my $oldfh = IO::File->new("< $oldfile"); + if(!$oldfh) { + return 0; + } + my @contents = <$oldfh>; # Suck in the entire file. + + # write the backup file: + + my $newfh = IO::File->new("> $newfile"); + if(!(defined $newfh)){ + return 0; + } + my $lines = scalar @contents; + for (my $i =0; $i < $lines; $i++) { + print $newfh ($contents[$i]); + } + + $oldfh->close; + $newfh->close; + + chmod(0660, $newfile); + + return 1; + + } else { + return 0; + } +} + +# +# InstallFile: Called to install an administrative file: +# - The file is created with .tmp +# - The .tmp file is then mv'd to +# This lugubrious procedure is done to ensure that we are never without +# a valid, even if dated, version of the file regardless of who crashes +# and when the crash occurs. +# +# Parameters: +# Name of the file +# File Contents. +# Return: +# nonzero - success. +# 0 - failure and $! has an errno. +# +sub InstallFile { + my $Filename = shift; + my $Contents = shift; + my $TempFile = $Filename.".tmp"; + + # Open the file for write: + + my $fh = IO::File->new("> $TempFile"); # Write to temp. + if(!(defined $fh)) { + &logthis(' Unable to create '.$TempFile.""); + return 0; + } + # write the contents of the file: + + print $fh ($Contents); + $fh->close; # In case we ever have a filesystem w. locking + + chmod(0660, $TempFile); + + # Now we can move install the file in position. + + move($TempFile, $Filename); + + return 1; +} + +# +# PushFile: Called to do an administrative push of a file. +# - Ensure the file being pushed is one we support. +# - Backup the old file to +# - Separate the contents of the new file out from the +# rest of the request. +# - Write the new file. +# Parameter: +# Request - The entire user request. This consists of a : separated +# string pushfile:tablename:contents. +# NOTE: The contents may have :'s in it as well making things a bit +# more interesting... but not much. +# Returns: +# String to send to client ("ok" or "refused" if bad file). +# +sub PushFile { + my $request = shift; + my ($command, $filename, $contents) = split(":", $request, 3); + + # At this point in time, pushes for only the following tables are + # supported: + # hosts.tab ($filename eq host). + # domain.tab ($filename eq domain). + # Construct the destination filename or reject the request. + # + # lonManage is supposed to ensure this, however this session could be + # 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 { + return "refused"; + } + # + # >copy< the old table to the backup table + # don't rename in case system crashes/reboots etc. in the time + # window between a rename and write. + # + my $backupfile = $tablefile; + $backupfile =~ s/\.tab$/.old/; + if(!CopyFile($tablefile, $backupfile)) { + &logthis(' CopyFile from '.$tablefile." to ".$backupfile." failed "); + return "error:$!"; + } + &logthis(' Pushfile: backed up ' + .$tablefile." to $backupfile"); + + # Install the new file: + + if(!InstallFile($tablefile, $contents)) { + &logthis(' Pushfile: unable to install ' + .$tablefile." $! "); + return "error:$!"; + } + else { + &logthis(' Installed new '.$tablefile + .""); + + } + + + # Indicate success: + + return "ok"; + +} + +# +# Called to re-init either lonc or lond. +# +# Parameters: +# request - The full request by the client. This is of the form +# reinit: +# where is allowed to be either of +# lonc or lond +# +# Returns: +# The string to be sent back to the client either: +# ok - Everything worked just fine. +# error:why - There was a failure and why describes the reason. +# +# +sub ReinitProcess { + my $request = shift; + + return 'ok'; +} + +# # Convert an error return code from lcpasswd to a string value. # sub lcpasswdstrerror { @@ -142,7 +409,7 @@ sub catchexception { $SIG{'QUIT'}='DEFAULT'; $SIG{__DIE__}='DEFAULT'; &logthis("CRITICAL: " - ."ABNORMAL EXIT. Child $$ for server $wasserver died through " + ."ABNORMAL EXIT. Child $$ for server $thisserver died through " ."a crash with this error msg->[$error]"); &logthis('Famous last words: '.$status.' - '.$lastlog); if ($client) { print $client "error: $error\n"; } @@ -162,14 +429,14 @@ $SIG{__DIE__}=\&catchexception; # ---------------------------------- 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}; +%perlvar=%{$perlvarref}; undef $perlvarref; # ----------------------------- Make sure this process is running from user=www my $wwwid=getpwnam('www'); if ($wwwid!=$<) { - $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; - $subj="LON: $perlvar{'lonHostID'} User ID mismatch"; + my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; + my $subj="LON: $currenthostid User ID mismatch"; system("echo 'User ID mismatch. lond must be run as user www.' |\ mailto $emailto -s '$subj' > /dev/null"); exit 1; @@ -186,18 +453,17 @@ if (-e $pidfile) { if (kill 0 => $pide) { die "already running"; } } -$PREFORK=4; # number of children to maintain, at least four spare - # ------------------------------------------------------------- Read hosts file open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file"; -while ($configline=) { +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; } - $PREFORK++; } close(CONFIG); @@ -213,10 +479,8 @@ $server = IO::Socket::INET->new(LocalPor # global variables -$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 +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; @@ -245,16 +509,29 @@ sub HUPSMAN { # sig kill 'INT' => keys %children; &logthis("Free socket: ".shutdown($server,2)); # free up socket &logthis("CRITICAL: Restarting"); - unlink("$execdir/logs/lond.pid"); my $execdir=$perlvar{'lonDaemons'}; + unlink("$execdir/logs/lond.pid"); exec("$execdir/lond"); # here we go again } +# +# Called in response to a USR2 signal. +# - Reread hosts.tab +# - All children connected to hosts that were removed from hosts.tab +# are killed via SIGINT +# - All children connected to previously existing hosts are sent SIGUSR1 +# - Our internal hosts hash is updated to reflect the new contents of +# hosts.tab causing connections from hosts added to hosts.tab to +# now be honored. +# +sub UpdateHosts { +} + sub checkchildren { &initnewstatus(); &logstatus(); &logthis('Going to check on the children'); - $docdir=$perlvar{'lonDocRoot'}; + my $docdir=$perlvar{'lonDocRoot'}; foreach (sort keys %children) { sleep 1; unless (kill 'USR1' => $_) { @@ -263,17 +540,25 @@ sub checkchildren { } } sleep 5; + $SIG{ALRM} = sub { die "timeout" }; + $SIG{__DIE__} = 'DEFAULT'; foreach (sort keys %children) { unless (-e "$docdir/lon-status/londchld/$_.txt") { + eval { + alarm(300); &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.$_` + #$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}"; + #$subj="LON: $currenthostid 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.$_`; + alarm(0); + } } } + $SIG{ALRM} = 'DEFAULT'; + $SIG{__DIE__} = \&cathcexception; } # --------------------------------------------------------------------- Logging @@ -301,7 +586,7 @@ sub logstatus { my $docdir=$perlvar{'lonDocRoot'}; { my $fh=IO::File->new(">>$docdir/lon-status/londstatus.txt"); - print $fh $$."\t".$status."\t".$lastlog."\n"; + print $fh $$."\t".$currenthostid."\t".$status."\t".$lastlog."\n"; $fh->close(); } { @@ -318,7 +603,7 @@ sub initnewstatus { my $local=localtime($now); print $fh "LOND status $local - parent $$\n\n"; opendir(DIR,"$docdir/lon-status/londchld"); - while ($filename=readdir(DIR)) { + while (my $filename=readdir(DIR)) { unlink("$docdir/lon-status/londchld/$filename"); } closedir(DIR); @@ -362,13 +647,6 @@ sub reconlonc { if (kill 0 => $loncpid) { &logthis("lonc at pid $loncpid responding, sending USR1"); kill USR1 => $loncpid; - sleep 5; - if (-e "$peerfile") { return; } - &logthis("$peerfile still not there, give it another try"); - sleep 10; - if (-e "$peerfile") { return; } - &logthis( - "WARNING: $peerfile still not there, giving up"); } else { &logthis( "CRITICAL: " @@ -398,12 +676,12 @@ sub subreply { sub reply { my ($cmd,$server)=@_; my $answer; - if ($server ne $perlvar{'lonHostID'}) { + if ($server ne $currenthostid) { $answer=subreply($cmd,$server); if ($answer eq 'con_lost') { $answer=subreply("ping",$server); if ($answer ne $server) { - &logthis("sub reply: answer != server"); + &logthis("sub reply: answer != server answer is $answer, server is $server"); &reconlonc("$perlvar{'lonSockDir'}/$server"); } $answer=subreply($cmd,$server); @@ -467,7 +745,7 @@ sub ishome { # ======================================================= Continue main program # ---------------------------------------------------- Fork once and dissociate -$fpid=fork; +my $fpid=fork; exit if $fpid; die "Couldn't fork: $!" unless defined ($fpid); @@ -475,7 +753,7 @@ POSIX::setsid() or die "Can't start new # ------------------------------------------------------- Write our PID on disk -$execdir=$perlvar{'lonDaemons'}; +my $execdir=$perlvar{'lonDaemons'}; open (PIDSAVE,">$execdir/logs/lond.pid"); print PIDSAVE "$$\n"; close(PIDSAVE); @@ -491,7 +769,7 @@ $SIG{CHLD} = \&REAPER; $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; $SIG{HUP} = \&HUPSMAN; $SIG{USR1} = \&checkchildren; - +$SIG{USR2} = \&UpdateHosts; # -------------------------------------------------------------- @@ -505,7 +783,6 @@ while (1) { } sub make_new_child { - my $client; my $pid; my $cipher; my $sigset; @@ -516,7 +793,7 @@ sub make_new_child { $sigset = POSIX::SigSet->new(SIGINT); sigprocmask(SIG_BLOCK, $sigset) or die "Can't block SIGINT for fork: $!\n"; - + die "fork: $!" unless defined ($pid = fork); if ($pid) { @@ -530,6 +807,8 @@ sub make_new_child { } else { # Child can *not* return from this subroutine. $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before + $SIG{CHLD} = 'DEFAULT'; #make this default so that pwauth returns + #don't get intercepted $SIG{USR1}= \&logstatus; $SIG{ALRM}= \&timeout; $lastlog='Forked '; @@ -539,7 +818,7 @@ sub make_new_child { sigprocmask(SIG_UNBLOCK, $sigset) or die "Can't unblock SIGINT for fork: $!\n"; - $tmpsnum=0; + my $tmpsnum=0; #---------------------------------------------------- kerberos 5 initialization &Authen::Krb5::init_context(); &Authen::Krb5::init_ets(); @@ -553,18 +832,19 @@ sub make_new_child { # see if we know client and check for spoof IP by challenge my $caller = getpeername($client); my ($port,$iaddr)=unpack_sockaddr_in($caller); - my $clientip=inet_ntoa($iaddr); + $clientip=inet_ntoa($iaddr); my $clientrec=($hostid{$clientip} ne undef); &logthis( -"INFO: Connection $i, $clientip ($hostid{$clientip})" +"INFO: Connection, $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') { + $remotereq=~s/[^\w:]//g; + if ($remotereq =~ /^init/) { + &sethost("sethost:$perlvar{'lonHostID'}"); my $challenge="$$".time; print $client "$challenge\n"; &status( @@ -593,9 +873,15 @@ sub make_new_child { if ($clientok) { # ---------------- New known client connecting, could mean machine online again - &reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); - &logthis( - "Established connection: $hostid{$clientip}"); + foreach my $id (keys(%hostip)) { + if ($hostip{$id} ne $clientip || + $hostip{$currenthostid} eq $clientip) { + # no need to try to do recon's to myself + next; + } + &reconlonc("$perlvar{'lonSockDir'}/$id"); + } + &logthis("Established connection: $hostid{$clientip}"); &status('Will listen to '.$hostid{$clientip}); # ------------------------------------------------------------ Process requests while (my $userinput=<$client>) { @@ -623,17 +909,17 @@ sub make_new_child { # ------------------------------------------------------------- Normal commands # ------------------------------------------------------------------------ ping if ($userinput =~ /^ping/) { - print $client "$perlvar{'lonHostID'}\n"; + print $client "$currenthostid\n"; # ------------------------------------------------------------------------ pong - } elsif ($userinput =~ /^pong/) { - $reply=reply("ping",$hostid{$clientip}); - print $client "$perlvar{'lonHostID'}:$reply\n"; + }elsif ($userinput =~ /^pong/) { + my $reply=&reply("ping",$hostid{$clientip}); + print $client "$currenthostid:$reply\n"; # ------------------------------------------------------------------------ ekey } elsif ($userinput =~ /^ekey/) { my $buildkey=time.$$.int(rand 100000); $buildkey=~tr/1-6/A-F/; $buildkey=int(rand 100000).$buildkey.int(rand 100000); - my $key=$perlvar{'lonHostID'}.$hostid{$clientip}; + my $key=$currenthostid.$hostid{$clientip}; $key=~tr/a-z/A-Z/; $key=~tr/G-P/0-9/; $key=~tr/Q-Z/0-9/; @@ -650,8 +936,16 @@ sub make_new_child { $loadavg=<$loadfile>; } $loadavg =~ s/\s.*//g; - my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; + my $loadpercent=100*$loadavg/$perlvar{'lonLoadLim'}; print $client "$loadpercent\n"; +# -------------------------------------------------------------------- userload + } elsif ($userinput =~ /^userload/) { + my $userloadpercent=&userload(); + print $client "$userloadpercent\n"; + +# +# Transactions requiring encryption: +# # ----------------------------------------------------------------- currentauth } elsif ($userinput =~ /^currentauth/) { if ($wasenc==1) { @@ -666,6 +960,32 @@ sub make_new_child { } else { print $client "refused\n"; } +#--------------------------------------------------------------------- pushfile + } elsif($userinput =~ /^pushfile/) { + if($wasenc == 1) { + my $cert = GetCertificate($userinput); + if(ValidManager($cert)) { + my $reply = PushFile($userinput); + print $client "$reply\n"; + } else { + print $client "refused\n"; + } + } else { + print $client "refused\n"; + } +#--------------------------------------------------------------------- reinit + } elsif($userinput =~ /^reinit/) { + if ($wasenc == 1) { + my $cert = GetCertificate($userinput); + if(ValidManager($cert)) { + my $reply = ReinitProcess($userinput); + print $client "$reply\n"; + } else { + print $client "refused\n"; + } + } else { + print $client "refused\n"; + } # ------------------------------------------------------------------------ auth } elsif ($userinput =~ /^auth/) { if ($wasenc==1) { @@ -706,7 +1026,7 @@ sub make_new_child { } } } elsif ($howpwd eq 'krb4') { - $null=pack("C",0); + my $null=pack("C",0); unless ($upass=~/$null/) { my $krb4_error = &Authen::Krb4::get_pw_in_tkt ($uname,"",$contentpwd,'krbtgt', @@ -723,7 +1043,7 @@ sub make_new_child { } } } elsif ($howpwd eq 'krb5') { - $null=pack("C",0); + my $null=pack("C",0); unless ($upass=~/$null/) { my $krbclient=&Authen::Krb5::parse_name($uname.'@'.$contentpwd); my $krbservice="krbtgt/".$contentpwd."\@".$contentpwd; @@ -777,10 +1097,18 @@ sub make_new_child { 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"; + { + my $pf; + if ($pf = IO::File->new(">$passfilename")) { + print $pf "internal:$ncpass\n"; + &logthis("Result of password change for $uname: pwchange_success"); + print $client "ok\n"; + } else { + &logthis("Unable to open $uname passwd to change password"); + print $client "non_authorized\n"; + } + } + } else { print $client "non_authorized\n"; } @@ -807,7 +1135,7 @@ sub make_new_child { if ($pwdcorrect) { my $execdir=$perlvar{'lonDaemons'}; &Debug("Opening lcpasswd pipeline"); - my $pf = IO::File->new("|$execdir/lcpasswd > /home/www/lcpasswd.log"); + my $pf = IO::File->new("|$execdir/lcpasswd > $perlvar{'lonDaemons'}/logs/lcpasswd.log"); print $pf "$uname\n$npass\n$npass\n"; close $pf; my $err = $?; @@ -845,13 +1173,13 @@ sub make_new_child { $passfilename); if (-e $passfilename) { print $client "already_exists\n"; - } elsif ($udom ne $perlvar{'lonDefDomain'}) { + } elsif ($udom ne $currentdomainid) { print $client "not_right_domain\n"; } else { - @fpparts=split(/\//,$proname); - $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; - $fperror=''; - for ($i=3;$i<=$#fpparts;$i++) { + my @fpparts=split(/\//,$proname); + my $fpnow=$fpparts[0].'/'.$fpparts[1].'/'.$fpparts[2]; + my $fperror=''; + for (my $i=3;$i<=$#fpparts;$i++) { $fpnow.='/'.$fpparts[$i]; unless (-e $fpnow) { unless (mkdir($fpnow,0777)) { @@ -885,7 +1213,7 @@ sub make_new_child { $npass=&unescape($npass); my $proname=&propath($udom,$uname); my $passfilename="$proname/passwd"; - if ($udom ne $perlvar{'lonDefDomain'}) { + if ($udom ne $currentdomainid) { print $client "not_right_domain\n"; } else { my $result=&make_passwd_file($uname, $umode,$npass, @@ -915,11 +1243,11 @@ sub make_new_child { $uid,$gid,$rdev,$size, $atime,$mtime,$ctime, $blksize,$blocks)=stat($fname); - $now=time; - $since=$now-$atime; + my $now=time; + my $since=$now-$atime; if ($since>$perlvar{'lonExpire'}) { - $reply= - reply("unsub:$fname","$hostid{$clientip}"); + my $reply= + &reply("unsub:$fname","$hostid{$clientip}"); unlink("$fname"); } else { my $transname="$fname.in.transfer"; @@ -990,16 +1318,16 @@ sub make_new_child { } elsif ($userinput =~ /^tokenauthuserfile/) { my ($cmd,$fname,$session)=split(/:/,$userinput); chomp($session); - $reply='non_auth'; + my $reply='non_auth'; if (open(ENVIN,$perlvar{'lonIDsDir'}.'/'. - $session.'.id')) { - while ($line=) { - if ($line=~/userfile\.$fname\=/) { $reply='ok'; } - } - close(ENVIN); - print $client $reply."\n"; + $session.'.id')) { + while (my $line=) { + if ($line=~/userfile\.$fname\=/) { $reply='ok'; } + } + close(ENVIN); + print $client $reply."\n"; } else { - print $client "invalid_token\n"; + print $client "invalid_token\n"; } # ----------------------------------------------------------------- unsubscribe } elsif ($userinput =~ /^unsub/) { @@ -1050,9 +1378,10 @@ sub make_new_child { ) { print $hfh "P:$now:$what\n"; } } my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { - foreach $pair (@pairs) { - ($key,$value)=split(/=/,$pair); + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); $hash{$key}=$value; } if (untie(%hash)) { @@ -1092,14 +1421,14 @@ sub make_new_child { } } my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { - foreach $pair (@pairs) { - ($key,$value)=split(/=/,$pair); + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); &ManagePermissions($key, $udom, $uname, &GetAuthType( $udom, $uname)); $hash{$key}=$value; - } if (untie(%hash)) { print $client "ok\n"; @@ -1116,6 +1445,48 @@ sub make_new_child { } else { print $client "refused\n"; } +# -------------------------------------------------------------------- rolesdel + } elsif ($userinput =~ /^rolesdel/) { + &Debug("rolesdel"); + 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); + my $now=time; + { + my $hfh; + if ( + $hfh=IO::File->new(">>$proname/$namespace.hist") + ) { + print $hfh "D:$now:$exedom:$exeuser:$what\n"; + } + } + my @rolekeys=split(/\&/,$what); + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + foreach my $key (@rolekeys) { + delete $hash{$key}; + } + if (untie(%hash)) { + print $client "ok\n"; + } else { + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting rolesdel\n"; + } + } else { + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting rolesdel\n"; + } + } else { + print $client "refused\n"; + } # ------------------------------------------------------------------------- get } elsif ($userinput =~ /^get/) { my ($cmd,$udom,$uname,$namespace,$what) @@ -1126,8 +1497,9 @@ sub make_new_child { my @queries=split(/\&/,$what); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { - for ($i=0;$i<=$#queries;$i++) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + for (my $i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } if (untie(%hash)) { @@ -1139,9 +1511,14 @@ sub make_new_child { "while attempting get\n"; } } else { - print $client "error: ".($!+0) - ." tie(GDBM) Failed ". - "while attempting get\n"; + if ($!+0 == 2) { + print $client "error:No such file or ". + "GDBM reported bad block error\n"; + } else { + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting get\n"; + } } # ------------------------------------------------------------------------ eget } elsif ($userinput =~ /^eget/) { @@ -1153,8 +1530,9 @@ sub make_new_child { my @queries=split(/\&/,$what); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { - for ($i=0;$i<=$#queries;$i++) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + for (my $i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } if (untie(%hash)) { @@ -1199,8 +1577,9 @@ sub make_new_child { ) { print $hfh "D:$now:$what\n"; } } my @keys=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { - foreach $key (@keys) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { + foreach my $key (@keys) { delete($hash{$key}); } if (untie(%hash)) { @@ -1223,8 +1602,9 @@ sub make_new_child { $namespace=~s/\W//g; my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { - foreach $key (keys %hash) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + foreach my $key (keys %hash) { $qresult.="$key&"; } if (untie(%hash)) { @@ -1248,6 +1628,7 @@ sub make_new_child { $namespace=~s/\W//g; my $qresult=''; my $proname=propath($udom,$uname); + my %hash; if (tie(%hash,'GDBM_File', "$proname/$namespace.db", &GDBM_READER(),0640)) { @@ -1298,9 +1679,10 @@ sub make_new_child { } my $qresult=''; my $proname=propath($udom,$uname); - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { study($regexp); - while (($key,$value) = each(%hash)) { + while (my ($key,$value) = each(%hash)) { if ($regexp eq '.') { $qresult.=$key.'='.$value.'&'; } else { @@ -1340,15 +1722,15 @@ sub make_new_child { ) { print $hfh "P:$now:$rid:$what\n"; } } my @pairs=split(/\&/,$what); - - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT,0640)) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_WRCREAT(),0640)) { my @previouskeys=split(/&/,$hash{"keys:$rid"}); my $key; $hash{"version:$rid"}++; my $version=$hash{"version:$rid"}; my $allkeys=''; - foreach $pair (@pairs) { - ($key,$value)=split(/=/,$pair); + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); $allkeys.=$key.':'; $hash{"$version:$rid:$key"}=$value; } @@ -1379,7 +1761,8 @@ sub make_new_child { chomp($rid); my $proname=propath($udom,$uname); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER,0640)) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname/$namespace.db",&GDBM_READER(),0640)) { my $version=$hash{"version:$rid"}; $qresult.="version=$version&"; my $scope; @@ -1412,9 +1795,10 @@ sub make_new_child { print $client "ok\n"; # -------------------------------------------------------------------- chatretr } elsif ($userinput =~ /^chatretr/) { - my ($cmd,$cdom,$cnum)=split(/\:/,$userinput); + my + ($cmd,$cdom,$cnum,$udom,$uname)=split(/\:/,$userinput); my $reply=''; - foreach (&getchat($cdom,$cnum)) { + foreach (&getchat($cdom,$cnum,$udom,$uname)) { $reply.=&escape($_).':'; } $reply=~s/\:$//; @@ -1446,6 +1830,73 @@ sub make_new_child { ." IO::File->new Failed ". "while attempting queryreply\n"; } +# ----------------------------------------------------------------- courseidput + } elsif ($userinput =~ /^courseidput/) { + my ($cmd,$udom,$what)=split(/:/,$userinput); + chomp($what); + $udom=~s/\W//g; + my $proname= + "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; + my $now=time; + my @pairs=split(/\&/,$what); + my %hash; + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); + $hash{$key}=$value.':'.$now; + } + if (untie(%hash)) { + print $client "ok\n"; + } else { + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting courseidput\n"; + } + } else { + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting courseidput\n"; + } +# ---------------------------------------------------------------- courseiddump + } elsif ($userinput =~ /^courseiddump/) { + my ($cmd,$udom,$since,$description) + =split(/:/,$userinput); + if (defined($description)) { + $description=&unescape($description); + } else { + $description='.'; + } + unless (defined($since)) { $since=0; } + my $qresult=''; + my $proname= + "$perlvar{'lonUsersDir'}/$udom/nohist_courseids"; + my %hash; + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { + while (my ($key,$value) = each(%hash)) { + my ($descr,$lasttime)=split(/\:/,$value); + if ($lasttime<$since) { next; } + if ($description eq '.') { + $qresult.=$key.'='.$descr.'&'; + } else { + my $unescapeVal = &unescape($descr); + if (eval('$unescapeVal=~/$description/i')) { + $qresult.="$key=$descr&"; + } + } + } + if (untie(%hash)) { + chop($qresult); + print $client "$qresult\n"; + } else { + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting courseiddump\n"; + } + } else { + print $client "error: ".($!+0) + ." tie(GDBM) Failed ". + "while attempting courseiddump\n"; + } # ----------------------------------------------------------------------- idput } elsif ($userinput =~ /^idput/) { my ($cmd,$udom,$what)=split(/:/,$userinput); @@ -1460,9 +1911,10 @@ sub make_new_child { ) { print $hfh "P:$now:$what\n"; } } my @pairs=split(/\&/,$what); - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT,0640)) { - foreach $pair (@pairs) { - ($key,$value)=split(/=/,$pair); + my %hash; + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_WRCREAT(),0640)) { + foreach my $pair (@pairs) { + my ($key,$value)=split(/=/,$pair); $hash{$key}=$value; } if (untie(%hash)) { @@ -1485,17 +1937,18 @@ sub make_new_child { my $proname="$perlvar{'lonUsersDir'}/$udom/ids"; my @queries=split(/\&/,$what); my $qresult=''; - if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER,0640)) { - for ($i=0;$i<=$#queries;$i++) { + my %hash; + if (tie(%hash,'GDBM_File',"$proname.db",&GDBM_READER(),0640)) { + for (my $i=0;$i<=$#queries;$i++) { $qresult.="$hash{$queries[$i]}&"; } if (untie(%hash)) { - $qresult=~s/\&$//; - print $client "$qresult\n"; + $qresult=~s/\&$//; + print $client "$qresult\n"; } else { - print $client "error: ".($!+0) - ." untie(GDBM) Failed ". - "while attempting idget\n"; + print $client "error: ".($!+0) + ." untie(GDBM) Failed ". + "while attempting idget\n"; } } else { print $client "error: ".($!+0) @@ -1577,6 +2030,19 @@ sub make_new_child { } if ($ulsout eq '') { $ulsout='empty'; } print $client "$ulsout\n"; +# ----------------------------------------------------------------- setannounce + } elsif ($userinput =~ /^setannounce/) { + my ($cmd,$announcement)=split(/:/,$userinput); + chomp($announcement); + $announcement=&unescape($announcement); + if (my $store=IO::File->new('>'.$perlvar{'lonDocRoot'}. + '/announcement.txt')) { + print $store $announcement; + close $store; + print $client "ok\n"; + } else { + print $client "error: ".($!+0)."\n"; + } # ------------------------------------------------------------------ Hanging up } elsif (($userinput =~ /^exit/) || ($userinput =~ /^init/)) { @@ -1586,6 +2052,10 @@ sub make_new_child { $client->close(); last; # ------------------------------------------------------------- unknown command + } elsif ($userinput =~ /^sethost:/) { + print $client &sethost($userinput)."\n"; + } elsif ($userinput =~/^version:/) { + print $client &version($userinput)."\n"; } else { # unknown command print $client "unknown_cmd\n"; @@ -1636,11 +2106,11 @@ sub ManagePermissions my $authtype= shift; # 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" ; - Debug("system $execdir/lchtmldir $userhome $system $authtype"); + &logthis("system $execdir/lchtmldir $userhome $user $authtype"); system("$execdir/lchtmldir $userhome $user $authtype"); } } @@ -1683,6 +2153,7 @@ sub addline { my $found=0; my $expr='^'.$hostid.':'.$ip.':'; $expr =~ s/\./\\\./g; + my $sh; if ($sh=IO::File->new("$fname.subscription")) { while (my $subline=<$sh>) { if ($subline !~ /$expr/) {$contents.= $subline;} else {$found=1;} @@ -1697,7 +2168,7 @@ sub addline { } sub getchat { - my ($cdom,$cname)=@_; + my ($cdom,$cname,$udom,$uname)=@_; my %hash; my $proname=&propath($cdom,$cname); my @entries=(); @@ -1706,7 +2177,19 @@ sub getchat { @entries=map { $_.':'.$hash{$_} } sort keys %hash; untie %hash; } - return @entries; + my @participants=(); + my $cutoff=time-60; + if (tie(%hash,'GDBM_File',"$proname/nohist_inchatroom.db", + &GDBM_WRCREAT(),0640)) { + $hash{$uname.':'.$udom}=time; + foreach (sort keys %hash) { + if ($hash{$_}>$cutoff) { + $participants[$#participants+1]='active_participant:'.$_; + } + } + untie %hash; + } + return (@participants,@entries); } sub chatadd { @@ -1714,10 +2197,10 @@ sub chatadd { my %hash; my $proname=&propath($cdom,$cname); my @entries=(); + my $time=time; 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'; @@ -1737,6 +2220,12 @@ sub chatadd { } untie %hash; } + { + my $hfh; + if ($hfh=IO::File->new(">>$proname/chatroom.log")) { + print $hfh "$time:".&unescape($newchat)."\n"; + } + } } sub unsub { @@ -1763,28 +2252,34 @@ sub currentversion { if ($fname=~/^(.+)\/[^\/]+$/) { $ulsdir=$1; } + my ($fnamere1,$fnamere2); + # remove version if already specified $fname=~s/\.\d+\.(\w+(?:\.meta)*)$/\.$1/; - $fname=~s/\.(\w+(?:\.meta)*)$/\.\(\\d\+\)\.$1\$/; - + # get the bits that go before and after the version number + if ( $fname=~/^(.*\.)(\w+(?:\.meta)*)$/ ) { + $fnamere1=$1; + $fnamere2='.'.$2; + } if (-e $fname) { $version=1; } if (-e $ulsdir) { - if(-d $ulsdir) { - if (opendir(LSDIR,$ulsdir)) { - while ($ulsfn=readdir(LSDIR)) { + if(-d $ulsdir) { + if (opendir(LSDIR,$ulsdir)) { + my $ulsfn; + 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; + my $thisfile=$ulsdir.'/'.$ulsfn; + unless (-l $thisfile) { + if ($thisfile=~/\Q$fnamere1\E(\d+)\Q$fnamere2\E/) { + if ($1>$version) { $version=$1; } + } + } + } + closedir(LSDIR); + $version++; + } + } + } + return $version; } sub thisversion { @@ -1823,7 +2318,7 @@ sub subscribe { $result="directory\n"; } else { if (-e "$fname.$hostid{$clientip}") {&unsub($fname,$clientip);} - $now=time; + my $now=time; my $found=&addline($fname,$hostid{$clientip},$clientip, "$hostid{$clientip}:$clientip:$now\n"); if ($found) { $result="$fname\n"; } @@ -1872,7 +2367,7 @@ sub make_passwd_file { { &Debug("Executing external: ".$execpath); &Debug("user = ".$uname.", Password =". $npass); - my $se = IO::File->new("|$execpath > /home/www/lcuseradd.log"); + my $se = IO::File->new("|$execpath > $perlvar{'lonDaemons'}/logs/lcuseradd.log"); print $se "$uname\n"; print $se "$npass\n"; print $se "$npass\n"; @@ -1895,6 +2390,51 @@ sub make_passwd_file { return $result; } +sub sethost { + my ($remotereq) = @_; + my (undef,$hostid)=split(/:/,$remotereq); + if (!defined($hostid)) { $hostid=$perlvar{'lonHostID'}; } + if ($hostip{$perlvar{'lonHostID'}} eq $hostip{$hostid}) { + $currenthostid=$hostid; + $currentdomainid=$hostdom{$hostid}; + &logthis("Setting hostid to $hostid, and domain to $currentdomainid"); + } else { + &logthis("Requested host id $hostid not an alias of ". + $perlvar{'lonHostID'}." refusing connection"); + return 'unable_to_set'; + } + return 'ok'; +} + +sub version { + my ($userinput)=@_; + $remoteVERSION=(split(/:/,$userinput))[1]; + return "version:$VERSION"; +} + +#There is a copy of this in lonnet.pm +sub userload { + my $numusers=0; + { + opendir(LONIDS,$perlvar{'lonIDsDir'}); + my $filename; + my $curtime=time; + while ($filename=readdir(LONIDS)) { + if ($filename eq '.' || $filename eq '..') {next;} + my ($mtime)=(stat($perlvar{'lonIDsDir'}.'/'.$filename))[9]; + if ($curtime-$mtime < 3600) { $numusers++; } + } + closedir(LONIDS); + } + my $userloadpercent=0; + my $maxuserload=$perlvar{'lonUserLoadLim'}; + if ($maxuserload) { + $userloadpercent=100*$numusers/$maxuserload; + } + $userloadpercent=sprintf("%.2f",$userloadpercent); + return $userloadpercent; +} + # ----------------------------------- POD (plain old documentation, CPAN style) =head1 NAME @@ -2004,6 +2544,17 @@ each connection is logged. =item * +SIGUSR2 + +Parent Signal assignment: + $SIG{USR2} = \&UpdateHosts + +Child signal assignment: + NONE + + +=item * + SIGCHLD Parent signal assignment: @@ -2164,6 +2715,17 @@ Send along temporarily stored informatio List part of a user's directory. +=item pushtable + +Pushes a file in /home/httpd/lonTab directory. Currently limited to: +hosts.tab and domain.tab. The old file is copied to *.tab.backup but +must be restored manually in case of a problem with the new table file. +pushtable requires that the request be encrypted and validated via +ValidateManager. The form of the command is: +enc:pushtable tablename \n +where pushtable, tablename and will be encrypted, but \n is a +cleartext newline. + =item Hanging up (exit or init) What to do when a client tells the server that they (the client) @@ -2174,6 +2736,7 @@ are leaving the network. 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,