#!/usr/bin/perl -w
# This is a simple pre-forking server, originally written for Cyrus imapd
#   pwcheck and notify_unix. See `perldoc Net::Server::Prefork`.
#
# The preforking server code is based on The Perl Cookbook (O'Reilly), Recipe 17.12.
#   If you haven't already, get The Perl CD Bookshelf (O'Reilly), which includes
#   a nicely hyperlinked version of Perl Cookbook, amongst other things.
#   See http://www1.fatbrain.com/asp/bookinfo/bookinfo.asp?theisbn=1565924622
#
# Standard Perl idioms for creating a daemon are used. See
#   http://www.webreference.com/perl/tutorial/9/index.html
#   for a good reference. Also see perldoc perlipc
#
# This code is (C) Jeremy Howard <j@howard.fm>, licensed under the same terms
#   as Perl itself (GPL2 or Artistic license).
#

package Net::Server::Prefork;

require 5.005;
use IO::Socket;
use Data::Dumper;
use Symbol;
use Unix::Syslog qw(:macros :subs);
use POSIX qw(setuid sigprocmask setsid SIGINT SIG_BLOCK SIG_UNBLOCK);
use strict;

use vars qw($VERSION);
$VERSION = '0.01';

use constant PATH=>'/tmp/';
use constant LOGNAME=>'perl_server';
use constant SOCKETNAME=>'perl_server';
use constant PIDNAME=>'perl_server.pid';
use constant PREFORK               => 1;    # number of children to maintain
use constant MAX_CLIENTS_PER_CHILD => 500;  # number of clients each child should process
use constant USER => 0;
use constant GROUP => 0;

sub new {
  my $Proto = shift;
  my $Class = ref($Proto) || $Proto;
  my $Self = {};
  $Self->{_children}               = {};       # keys are current child process IDs
  $Self->{_num_children}           = 0;        # current number of children
  $Self->{_log_name} = LOGNAME;
  $Self->{_path} = PATH;
  $Self->{_pid_name} = PIDNAME;
  $Self->{_num_prefork} = PREFORK;
  $Self->{_max_clients} = MAX_CLIENTS_PER_CHILD;

  bless ($Self, $Class);
  return $Self;
}

sub start {
  my $Self = shift;

  if (-e $Self->pid_full_name()) {
    my $CurrPid;
    open PID_FH, $Self->pid_full_name();
    $CurrPid = <PID_FH>;
    close PID_FH;
    die "It looks like I'm already running as PID " . $CurrPid . 
      "\nIf this isn't right, delete " . $Self->pid_full_name() . "\n";
  }

#------------------------------------------------------------
# Set up socket
  my $log_name = $Self->get_log_name();
  Unix::Syslog::openlog($log_name, LOG_PID | LOG_CONS, LOG_DAEMON);
  unlink ($Self->socket_full_name());
# Save current default permissions for this process, and remove default 
#   permissions before creating socket
  my $UserId = $Self->get_user();
  my $GroupId = $Self->get_group();
  setuid $UserId;
  POSIX::setgid $GroupId;
  $>=$UserId;
  $<=$UserId;
  $(=$GroupId;
  $)=$GroupId;
  my $oldumask = umask(0027);
# Try and listen on socket defined by SOCKETNAME
  if (!($Self->{listen_socket} = IO::Socket::UNIX->new(
    Type=>SOCK_STREAM, Local=>$Self->socket_full_name(), Listen=>0))) { 
    Unix::Syslog::syslog LOG_ERR, "Could not open listen socket.", 0;
    die "Could not open listen socket."; 
  }
  syslog LOG_ERR, 'Listening on ' . $Self->socket_full_name();
# Restore this process's permissions
  umask($oldumask);

#------------------------------------------------------------
# Create child process--this will become the dispatcher process
  my $PID = SafeFork();
  if ($PID) {
    # Record child pid for killing later
    open PID_FH, '>'.$Self->pid_full_name();
    print PID_FH $PID;
    close PID_FH;
    # Kill the parent process
    $PID && exit(0);
  }

# Fork off our children.
  for (1 .. $Self->get_num_prefork()) {
    $Self->make_new_child();
  }

# Install signal handlers.
  $SIG{CHLD} = sub{$Self->REAPER();};
  $SIG{INT}  = sub{$Self->HUNTSMAN();};

#------------------------------------------------------------
# And maintain the population.
  while (1) {
    sleep;                          # wait for a signal (i.e., child's death)
    for (my $i = $Self->get_num_children(); $i < $Self->get_num_prefork(); $i++) {
      $Self->make_new_child();           # top up the child pool
    }
  }
}

#------------------------------------------------------------
# This is the bit specfic to socket apps. Everything in SafeFork is generic
sub make_new_child {
  my $Self = shift || die "No object";
  my $pid = SafeFork();
  
  if ($pid) {
    $Self->{_children}->{$pid} = 1;
    $Self->{_num_children}++;
    return;
  } else {
    setuid $Self->get_user();
    $>=$Self->get_user();
    $<=$Self->get_user();
    chroot '/dev/null';

    # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
    for (my $i=0; $i < $Self->get_max_clients(); $i++) {
      my $sock = $Self->{listen_socket}->accept()     or last;
      # do the actual work!
      $Self->{_on_connect}->($sock);
    }

    # tidy up gracefully and finish
    # this exit is VERY important, otherwise the child will become
    # a producer of more and more children, forking yourself into
    # process death.
    exit;
  }
}

#------------------------------------------------------------
# takes care of dead children
sub REAPER {                        
  my $Self = shift || die "No object";
  $SIG{CHLD} = sub{$Self->REAPER();};
  my $pid = wait;
  $Self->{_num_children}--;
  delete $Self->{_children}->{$pid};
}

#------------------------------------------------------------
# signal handler for SIGINT
sub HUNTSMAN {                      
  my $Self = shift || die "No object";
  local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
  unlink ($Self->socket_full_name());
  unlink ($Self->pid_full_name());
  syslog LOG_ERR, "Exiting on INT signal.";
  kill ('INT' => keys %{$Self->{_children}});
  exit;                           # clean up with dignity
}

#------------------------------------------------------------------------------
# pid_full_name:  
#
sub pid_full_name {
  my $Self = shift || die "No object";
  return $Self->get_path() . $Self->get_pid_name();
}

#------------------------------------------------------------------------------
# socket_full_name: 
#
sub socket_full_name {
  my $Self = shift || die "No object";
  return $Self->get_path() . $Self->get_socket_name();
}

sub get_max_clients{ return $_[0]->{_max_clients} }
sub set_max_clients { return ($_[0]->{_max_clients} = $_[1]); }
sub get_num_prefork{ return $_[0]->{_num_prefork} }
sub set_num_prefork { return ($_[0]->{_num_prefork} = $_[1]); }
sub get_path{ return $_[0]->{_path} }
sub set_path { return ($_[0]->{_path} = $_[1]); }
sub get_pid_name{ return $_[0]->{_pid_name} }
sub set_pid_name { return ($_[0]->{_pid_name} = $_[1]); }
sub get_socket_name{ return $_[0]->{_socket_name} }
sub set_socket_name { return ($_[0]->{_socket_name} = $_[1]); }
sub get_log_name{ return $_[0]->{_log_name} }
sub set_log_name { return ($_[0]->{_log_name} = $_[1]); }
sub get_user{ return $_[0]->{_user} }
sub set_user { return ($_[0]->{_user} = $_[1]); }
sub get_group{ return $_[0]->{_group} }
sub set_group { return ($_[0]->{_group} = $_[1]); }
sub get_on_connect{ return $_[0]->{_on_connect} }
sub set_on_connect { return ($_[0]->{_on_connect} = $_[1]); }

#------------------------------------------------------------
# Fork off a new process in a safe way, and return the $pid
sub SafeFork {
  my ($sigset, $pid);
  
  # block signal for fork
  $sigset = POSIX::SigSet->new(SIGINT);
  sigprocmask(SIG_BLOCK, $sigset)
      or die "Can't block SIGINT for fork: $!\n";
  
  # Fork this process, to actually create the child
  die "fork: $!" unless defined ($pid = fork);
  if (!$pid) {
    # I'm the child--make me safe
    $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
    open STDIN,  '/dev/null' or die "Can't read /dev/null: $!";
    open STDOUT, '>/dev/null';
    open STDERR, '>/dev/null';
    # Change to root dir to avoid locking a mounted file system
    chdir '/'                 or die "Can't chdir to /: $!";
    # Turn process into session leader, and ensure no controlling terminal
    POSIX::setsid();
  }
  sigprocmask(SIG_UNBLOCK, $sigset)
      or die "Can't unblock SIGINT for fork: $!\n";
  return $pid;
}

1;
  __END__

=head1 NAME

Net::Server::Prefork - Preforking Unix sockets server

=head1 SYNOPSIS

  use IO::Socket;
  use Net::Server::Prefork;

  sub log_connection {
    my $sock = shift;

    my $line = $sock->getline();
    print "I received $line\n";
  }

  my $Server = Net::Server::Prefork->new;
  $Server->set_path('/var/pwcheck/');
  $Server->set_pid_name('notify_unix.pid');
  $Server->set_socket_name('notify_unix');
  $Server->set_log_name("notify_unix");
  $Server->set_num_prefork(5);

  $Server->set_user(getpwnam('cyrus'));
  $Server->set_group(getgrnam('mail'));

  $Server->set_on_connect(\&log_connection);

  $Server->start();

=head1 DESCRIPTION

Simple pre-forking Unix sockets server. Provide an on_connect callback as shown in the synopsis, and then fire off the start() method--voila! ...You have a preforking server!

To stop the server, send it an INT signal:

  kill -INT `cat /tmp/perl_server.pid`

The server lets you know what it is up to in the system log. It logs as 'perl_server', unless you use the set_log_name method to specify somethink else.

In the examples directory you can see some examples of this module used as a notify daemon for Cyrus IMAPd.

=head1 AUTHOR

Jeremy Howard; j@howard.fm

=head1 SEE ALSO

perl(1)

perldoc IO::Socket

=cut

