version 1.56, 2001/11/16 16:26:01
|
version 1.61, 2001/12/20 17:43:05
|
Line 1
|
Line 1
|
#!/usr/bin/perl |
#!/usr/bin/perl |
# The LearningOnline Network |
# The LearningOnline Network |
# lond "LON Daemon" Server (port "LOND" 5663) |
# lond "LON Daemon" Server (port "LOND" 5663) |
|
# |
|
# $Id$ |
|
# |
|
# 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, |
# 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, |
# 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/7,10/8,10/9,10/11,10/13,10/15,11/4,11/16, |
Line 10
|
Line 35
|
# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer |
# 06/29,06/30,07/14,07/15,07/17,07/20,07/25,09/18 Gerd Kortemeyer |
# 12/05 Scott Harrison |
# 12/05 Scott Harrison |
# 12/05,12/13,12/29 Gerd Kortemeyer |
# 12/05,12/13,12/29 Gerd Kortemeyer |
|
# YEAR=2001 |
# Jan 01 Scott Harrison |
# Jan 01 Scott Harrison |
# 02/12 Gerd Kortemeyer |
# 02/12 Gerd Kortemeyer |
# 03/15 Scott Harrison |
# 03/15 Scott Harrison |
Line 17
|
Line 43
|
# 04/02 Scott Harrison |
# 04/02 Scott Harrison |
# 05/11,05/28,08/30 Gerd Kortemeyer |
# 05/11,05/28,08/30 Gerd Kortemeyer |
# 9/30,10/22,11/13,11/15,11/16 Scott Harrison |
# 9/30,10/22,11/13,11/15,11/16 Scott Harrison |
|
# 11/26,11/27 Gerd Kortemeyer |
|
# 12/20 Scott Harrison |
# |
# |
# $Id$ |
|
### |
### |
|
|
# based on "Perl Cookbook" ISBN 1-56592-243-3 |
# based on "Perl Cookbook" ISBN 1-56592-243-3 |
Line 39 use Authen::Krb4;
|
Line 66 use Authen::Krb4;
|
use lib '/home/httpd/lib/perl/'; |
use lib '/home/httpd/lib/perl/'; |
use localauth; |
use localauth; |
|
|
|
my $status=''; |
|
my $lastlog=''; |
|
|
# grabs exception and records it to log before exiting |
# grabs exception and records it to log before exiting |
sub catchexception { |
sub catchexception { |
my ($error)=@_; |
my ($error)=@_; |
Line 47 sub catchexception {
|
Line 77 sub catchexception {
|
&logthis("<font color=red>CRITICAL: " |
&logthis("<font color=red>CRITICAL: " |
."ABNORMAL EXIT. Child $$ for server $wasserver died through " |
."ABNORMAL EXIT. Child $$ for server $wasserver died through " |
."a crash with this error msg->[$error]</font>"); |
."a crash with this error msg->[$error]</font>"); |
|
&logthis('Famous last words: '.$status.' - '.$lastlog); |
if ($client) { print $client "error: $error\n"; } |
if ($client) { print $client "error: $error\n"; } |
|
$server->close(); |
die($error); |
die($error); |
} |
} |
|
|
Line 133 sub REAPER { # ta
|
Line 165 sub REAPER { # ta
|
sub HUNTSMAN { # signal handler for SIGINT |
sub HUNTSMAN { # signal handler for SIGINT |
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children |
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children |
kill 'INT' => keys %children; |
kill 'INT' => keys %children; |
|
&logthis("Free socket: ".shutdown($server,2)); # free up socket |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
unlink("$execdir/logs/lond.pid"); |
unlink("$execdir/logs/lond.pid"); |
&logthis("<font color=red>CRITICAL: Shutting down</font>"); |
&logthis("<font color=red>CRITICAL: Shutting down</font>"); |
Line 142 sub HUNTSMAN { # si
|
Line 175 sub HUNTSMAN { # si
|
sub HUPSMAN { # signal handler for SIGHUP |
sub HUPSMAN { # signal handler for SIGHUP |
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children |
local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children |
kill 'INT' => keys %children; |
kill 'INT' => keys %children; |
close($server); # free up socket |
&logthis("Free socket: ".shutdown($server,2)); # free up socket |
&logthis("<font color=red>CRITICAL: Restarting</font>"); |
&logthis("<font color=red>CRITICAL: Restarting</font>"); |
unlink("$execdir/logs/lond.pid"); |
unlink("$execdir/logs/lond.pid"); |
my $execdir=$perlvar{'lonDaemons'}; |
my $execdir=$perlvar{'lonDaemons'}; |
exec("$execdir/lond"); # here we go again |
exec("$execdir/lond"); # here we go again |
} |
} |
|
|
|
sub checkchildren { |
|
&initnewstatus(); |
|
&logstatus(); |
|
&logthis('Going to check on the children'); |
|
foreach (sort keys %children) { |
|
sleep 1; |
|
unless (kill 'USR1' => $_) { |
|
&logthis ('Child '.$_.' is dead'); |
|
&logstatus($$.' is dead'); |
|
} |
|
} |
|
} |
|
|
# --------------------------------------------------------------------- Logging |
# --------------------------------------------------------------------- Logging |
|
|
sub logthis { |
sub logthis { |
Line 157 sub logthis {
|
Line 203 sub logthis {
|
my $fh=IO::File->new(">>$execdir/logs/lond.log"); |
my $fh=IO::File->new(">>$execdir/logs/lond.log"); |
my $now=time; |
my $now=time; |
my $local=localtime($now); |
my $local=localtime($now); |
|
$lastlog=$local.': '.$message; |
print $fh "$local ($$): $message\n"; |
print $fh "$local ($$): $message\n"; |
} |
} |
|
|
|
# ------------------------------------------------------------------ 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"; |
|
} |
|
|
|
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"; |
|
} |
|
|
|
# -------------------------------------------------------------- Status setting |
|
|
|
sub status { |
|
my $what=shift; |
|
my $now=time; |
|
my $local=localtime($now); |
|
$status=$local.': '.$what; |
|
} |
|
|
# -------------------------------------------------------- Escape Special Chars |
# -------------------------------------------------------- Escape Special Chars |
|
|
Line 306 open (PIDSAVE,">$execdir/logs/lond.pid")
|
Line 377 open (PIDSAVE,">$execdir/logs/lond.pid")
|
print PIDSAVE "$$\n"; |
print PIDSAVE "$$\n"; |
close(PIDSAVE); |
close(PIDSAVE); |
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>"); |
&logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>"); |
|
&status('Starting'); |
|
|
# ------------------------------------------------------- Now we are on our own |
# ------------------------------------------------------- Now we are on our own |
|
|
Line 316 for (1 .. $PREFORK) {
|
Line 388 for (1 .. $PREFORK) {
|
|
|
# ----------------------------------------------------- Install signal handlers |
# ----------------------------------------------------- Install signal handlers |
|
|
|
&status('Forked children'); |
|
|
$SIG{CHLD} = \&REAPER; |
$SIG{CHLD} = \&REAPER; |
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN; |
$SIG{INT} = $SIG{TERM} = \&HUNTSMAN; |
$SIG{HUP} = \&HUPSMAN; |
$SIG{HUP} = \&HUPSMAN; |
|
$SIG{USR1} = \&checkchildren; |
|
|
# And maintain the population. |
# And maintain the population. |
while (1) { |
while (1) { |
|
&status('Sleeping'); |
sleep; # wait for a signal (i.e., child's death) |
sleep; # wait for a signal (i.e., child's death) |
|
&logthis('Woke up'); |
|
&status('Woke up'); |
for ($i = $children; $i < $PREFORK; $i++) { |
for ($i = $children; $i < $PREFORK; $i++) { |
make_new_child(); # top up the child pool |
make_new_child(); # top up the child pool |
} |
} |
Line 346 sub make_new_child {
|
Line 424 sub make_new_child {
|
or die "Can't unblock SIGINT for fork: $!\n"; |
or die "Can't unblock SIGINT for fork: $!\n"; |
$children{$pid} = 1; |
$children{$pid} = 1; |
$children++; |
$children++; |
|
&status('Started child '.$pid); |
return; |
return; |
} else { |
} else { |
# Child can *not* return from this subroutine. |
# Child can *not* return from this subroutine. |
$SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before |
$SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before |
|
$SIG{USR1}= \&logstatus; |
|
$lastlog='Forked '; |
|
$status='Forked'; |
|
|
# unblock signals |
# unblock signals |
sigprocmask(SIG_UNBLOCK, $sigset) |
sigprocmask(SIG_UNBLOCK, $sigset) |
or die "Can't unblock SIGINT for fork: $!\n"; |
or die "Can't unblock SIGINT for fork: $!\n"; |
Line 359 sub make_new_child {
|
Line 441 sub make_new_child {
|
|
|
# handle connections until we've reached $MAX_CLIENTS_PER_CHILD |
# handle connections until we've reached $MAX_CLIENTS_PER_CHILD |
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { |
for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { |
|
&status('Idle, waiting for connection'); |
$client = $server->accept() or last; |
$client = $server->accept() or last; |
|
&status('Accepted connection'); |
# ============================================================================= |
# ============================================================================= |
# do something with the connection |
# do something with the connection |
# ----------------------------------------------------------------------------- |
# ----------------------------------------------------------------------------- |
Line 372 sub make_new_child {
|
Line 455 sub make_new_child {
|
&logthis( |
&logthis( |
"<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>" |
"<font color=yellow>INFO: Connection $i, $clientip ($hostid{$clientip})</font>" |
); |
); |
|
&status("Connecting $clientip ($hostid{$clientip})"); |
my $clientok; |
my $clientok; |
if ($clientrec) { |
if ($clientrec) { |
|
&status("Waiting for init from $clientip ($hostid{$clientip})"); |
my $remotereq=<$client>; |
my $remotereq=<$client>; |
$remotereq=~s/\W//g; |
$remotereq=~s/\W//g; |
if ($remotereq eq 'init') { |
if ($remotereq eq 'init') { |
my $challenge="$$".time; |
my $challenge="$$".time; |
print $client "$challenge\n"; |
print $client "$challenge\n"; |
|
&status( |
|
"Waiting for challenge reply from $clientip ($hostid{$clientip})"); |
$remotereq=<$client>; |
$remotereq=<$client>; |
$remotereq=~s/\W//g; |
$remotereq=~s/\W//g; |
if ($challenge eq $remotereq) { |
if ($challenge eq $remotereq) { |
Line 387 sub make_new_child {
|
Line 474 sub make_new_child {
|
} else { |
} else { |
&logthis( |
&logthis( |
"<font color=blue>WARNING: $clientip did not reply challenge</font>"); |
"<font color=blue>WARNING: $clientip did not reply challenge</font>"); |
print $client "bye\n"; |
&status('No challenge reply '.$clientip); |
} |
} |
} else { |
} else { |
&logthis( |
&logthis( |
"<font color=blue>WARNING: " |
"<font color=blue>WARNING: " |
."$clientip failed to initialize: >$remotereq< </font>"); |
."$clientip failed to initialize: >$remotereq< </font>"); |
print $client "bye\n"; |
&status('No init '.$clientip); |
} |
} |
} else { |
} else { |
&logthis( |
&logthis( |
"<font color=blue>WARNING: Unknown client $clientip</font>"); |
"<font color=blue>WARNING: Unknown client $clientip</font>"); |
print $client "bye\n"; |
&status('Hung up on '.$clientip); |
} |
} |
if ($clientok) { |
if ($clientok) { |
# ---------------- New known client connecting, could mean machine online again |
# ---------------- New known client connecting, could mean machine online again |
&reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); |
&reconlonc("$perlvar{'lonSockDir'}/$hostid{$clientip}"); |
&logthis( |
&logthis( |
"<font color=green>Established connection: $hostid{$clientip}</font>"); |
"<font color=green>Established connection: $hostid{$clientip}</font>"); |
|
&status('Will listen to '.$hostid{$clientip}); |
# ------------------------------------------------------------ Process requests |
# ------------------------------------------------------------ Process requests |
while (my $userinput=<$client>) { |
while (my $userinput=<$client>) { |
chomp($userinput); |
chomp($userinput); |
|
&status('Processing '.$hostid{$clientip}.': '.$userinput); |
my $wasenc=0; |
my $wasenc=0; |
# ------------------------------------------------------------ See if encrypted |
# ------------------------------------------------------------ See if encrypted |
if ($userinput =~ /^enc/) { |
if ($userinput =~ /^enc/) { |
Line 1230 sub make_new_child {
|
Line 1319 sub make_new_child {
|
&logthis( |
&logthis( |
"Client $clientip ($hostid{$clientip}) hanging up: $userinput"); |
"Client $clientip ($hostid{$clientip}) hanging up: $userinput"); |
print $client "bye\n"; |
print $client "bye\n"; |
|
$client->close(); |
last; |
last; |
# ------------------------------------------------------------- unknown command |
# ------------------------------------------------------------- unknown command |
} else { |
} else { |
# unknown command |
# unknown command |
print $client "unknown_cmd\n"; |
print $client "unknown_cmd\n"; |
} |
} |
# ------------------------------------------------------ client unknown, refuse |
# -------------------------------------------------------------------- complete |
|
&status('Listening to '.$hostid{$clientip}); |
} |
} |
|
# --------------------------------------------- client unknown or fishy, refuse |
} else { |
} else { |
print $client "refused\n"; |
print $client "refused\n"; |
|
$client->close(); |
&logthis("<font color=blue>WARNING: " |
&logthis("<font color=blue>WARNING: " |
."Rejected client $clientip, closing connection</font>"); |
."Rejected client $clientip, closing connection</font>"); |
} |
} |
Line 1250 sub make_new_child {
|
Line 1343 sub make_new_child {
|
|
|
# tidy up gracefully and finish |
# tidy up gracefully and finish |
|
|
|
$client->close(); |
|
$server->close(); |
|
|
# this exit is VERY important, otherwise the child will become |
# this exit is VERY important, otherwise the child will become |
# a producer of more and more children, forking yourself into |
# a producer of more and more children, forking yourself into |
# process death. |
# process death. |
Line 1257 sub make_new_child {
|
Line 1353 sub make_new_child {
|
} |
} |
} |
} |
|
|
|
# ----------------------------------- POD (plain old documentation, CPAN style) |
|
|
|
=head1 NAME |
|
|
|
lond - "LON Daemon" Server (port "LOND" 5663) |
|
|
|
=head1 SYNOPSIS |
|
|
|
Should only be run as user=www. Invoked by loncron. |
|
|
|
=head1 DESCRIPTION |
|
|
|
Preforker - server who forks first. Runs as a daemon. HUPs. |
|
Uses IDEA encryption |
|
|
|
=head1 README |
|
|
|
Not yet written. |
|
|
|
=head1 PREREQUISITES |
|
|
|
IO::Socket |
|
IO::File |
|
Apache::File |
|
Symbol |
|
POSIX |
|
Crypt::IDEA |
|
LWP::UserAgent() |
|
GDBM_File |
|
Authen::Krb4 |
|
|
|
=head1 COREQUISITES |
|
|
|
=head1 OSNAMES |
|
|
|
linux |
|
|
|
=head1 SCRIPT CATEGORIES |
|
|
|
Server/Process |
|
|
|
=cut |
|
|
|
|
|
|