El Módulo de Soporte: Versión con Log, Privilegios, chroot, Taint y Rearranque

Los cambios principales son los siguientes:

Se modifican las rutinas de fork (que ahora se hace en launch_child) y de manejo de la señal de CHLD para llevar en las claves del hash %CHILDREN los PIDs y en los valores los callbacks. Esto es manejado por la función reap_child:
```
  90  sub reap_child {
  91    while ( (my $child = waitpid(-1,WNOHANG)) > 0) {
  92      $CHILDREN{$child}->($child) if ref $CHILDREN{$child} eq 'CODE';
  93      delete $CHILDREN{$child};
  94    }
  95  }
```
Se modifica el código de fork de manera que los procesos hijo no hereden los manejadores de interrupción del padre
Se mantiene información adicional sobre el directorio de trabajo actual de modo que el daemon pueda rearrancarse en el mismo entorno en el que comenzó

Se ha añadido la función kill_children que termina todas las conexiones activas

  97  sub kill_children {
  98    kill TERM => keys %CHILDREN;
  99    # wait until all the children die
 100    sleep while %CHILDREN;
 101  }

Se añade la función do_realunch que relanza el servidor después de la recepción de una señal HUP:

 103  sub do_relaunch {
 104    $> = $<;  # regain privileges
 105    chdir $1 if $CWD =~ m!([./a-zA-z0-9_-]+)!;
 106    croak "bad program name" unless $0 =~ m!([./a-zA-z0-9_-]+)!;
 107    my $program = $1;
 108    my $port = $1 if $ARGV[0] =~ /(\d+)/;
 109    unlink $pidfile;
 110    exec 'perl','-T',$program,$port or croak "Couldn't exec: $!";
 111  }

Los procesos hijo por defecto heredan los manejadores de señales establecidos por el proceso padre. En consecuencia heredan el manejador de HUP el cual rearranca el servidor. No queremos que cada hijo ejecute este manejadorpues ello daría lugar a múltiples intentos opr los hijos de relanzar el servidor.

Para ello bastaría con establecer el manejador de señal de HUP para el hijo a DEFAULT. Existe no obstante el riesgo de que una señal de HUP llegue en el periodo que va desde la creación del hijo hasta la asignación

  73      $SIG{HUP} = $SIG{INT} = $SIG{CHLD} = $SIG{TERM} = 'DEFAULT';

Para ello se deben bloquear las señales antes de hacer el forking para desbloquearlas después tanto en el padre como en el hijo:

  64  sub launch_child {
  65    my $callback = shift;
  66    my $home     = shift;
  67    my $signals = POSIX::SigSet->new(SIGINT,SIGCHLD,SIGTERM,SIGHUP);
  68    sigprocmask(SIG_BLOCK,$signals);  # block inconvenient signals
  69    log_die("Can't fork: $!") unless defined (my $child = fork());
  70    if ($child) {
  71      $CHILDREN{$child} = $callback || 1;
  72    } else {
  73      $SIG{HUP} = $SIG{INT} = $SIG{CHLD} = $SIG{TERM} = 'DEFAULT';
  74      prepare_child($home);
  75    }
  76    sigprocmask(SIG_UNBLOCK,$signals);  # unblock signals
  77    return $child;
  78  }

La función sigprocmask del módulo POSIX lo hace posible. Se llama de la forma:

$result = sigprocmask($operation, $newsigset, [$oldsigset])

sigprocmask permite la manipulación de la máscara de señales del proceso: una máscatra de bits que controla que señales serán o no recibidas. Por defecto un proceso recibe todas las señales del sistema oeprativo pero podemos bloquear algunas modificando la máscara. Las señales no se descartan sino que se guardan esperando hasta el momento en el que el proceso desbloquee la señal.

Las operaciones pueden ser:

SIG_BLOCK Las señales indicadas se añaden a la máscara para bloqueo
SIG_UNBLOCK Las señales indicadas se retiran de la máscara, desbloqueando las señales
SIG_SETMASK La máscara de señales es borrada y reemplazada por el conjunto de señales inicado en $newsigset

sigprocmask retorna verdadero si tuvo éxito.

Las señales pueden ser creadas y examinadas utilizando la clase POSIX::SigSet .

El módulo importa las funciones POSIX correspondientes a la etiqueta :signal_h.

   1  package Daemon;
   2  use strict;
   3  our (@EXPORT, @ISA, @EXPORT_OK, $VERSION);
   4
   5  use POSIX qw(:signal_h setsid WNOHANG);
   6  use Carp 'croak','cluck';
   7  use Carp::Heavy;
   8  use File::Basename;
   9  use IO::File;
  10  use Cwd;
  11  use Sys::Syslog qw(:DEFAULT setlogsock);
  12  require Exporter;
  13
  14  @EXPORT_OK = qw(init_server prepare_child kill_children
  15                  launch_child do_relaunch
  16                  log_debug log_notice log_warn
  17                  log_die %CHILDREN);
  18  @EXPORT = @EXPORT_OK;
  19  @ISA = qw(Exporter);
  20  $VERSION = '1.00';

En la función become_daemon recordamos en la variable $CWD el directorio de arranque. El resto de la rutina no tiene cambios sustanciales:

  40  sub become_daemon {
  41    croak "Can't fork" unless defined (my $child = fork);
  42    exit 0 if $child;    # parent dies;
  43    POSIX::setsid();     # become session leader
  44    open(STDIN,"</dev/null");
  45    open(STDOUT,">/dev/null");
  46    open(STDERR,">&STDOUT");
  47    $CWD = getcwd;       # remember working directory
  48    chdir '/';           # change working directory
  49    umask(0);            # forget file mode creation mask
  50    $ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin';
  51    delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
  52    $SIG{CHLD} = \&reap_child;
  53  }

La variable $CWD será utilizada durante el rearranque del servidor.

 103  sub do_relaunch {
 104    $> = $<;  # regain privileges
 105    chdir $1 if $CWD =~ m!([./a-zA-z0-9_-]+)!;
 106    croak "bad program name" unless $0 =~ m!([./a-zA-z0-9_-]+)!;
 107    my $program = $1;
 108    my $port = $1 if $ARGV[0] =~ /(\d+)/;
 109    unlink $pidfile;
 110    exec 'perl','-T',$program,$port or croak "Couldn't exec: $!";
 111  }

El Módulo de Soporte

root@beowulf:/home/casiano/src/perl/serverwithhup# cat -n Daemon.pm
   1  package Daemon;
   2  use strict;
   3  our (@EXPORT, @ISA, @EXPORT_OK, $VERSION);
   4
   5  use POSIX qw(:signal_h setsid WNOHANG);
   6  use Carp 'croak','cluck';
   7  use Carp::Heavy;
   8  use File::Basename;
   9  use IO::File;
  10  use Cwd;
  11  use Sys::Syslog qw(:DEFAULT setlogsock);
  12  require Exporter;
  13
  14  @EXPORT_OK = qw(init_server prepare_child kill_children
  15                  launch_child do_relaunch
  16                  log_debug log_notice log_warn
  17                  log_die %CHILDREN);
  18  @EXPORT = @EXPORT_OK;
  19  @ISA = qw(Exporter);
  20  $VERSION = '1.00';
  21
  22  use constant PIDPATH  => '/var/run';
  23  use constant FACILITY => 'local0';
  24  our %CHILDREN;
  25  my ($pid,$pidfile,$saved_dir,$CWD);
  26
  27  sub init_server {
  28    my ($user,$group);
  29    ($pidfile,$user,$group) = @_;
  30    $pidfile ||= getpidfilename();
  31    my $fh = open_pid_file($pidfile);
  32    become_daemon();
  33    print $fh $$;
  34    close $fh;
  35    init_log();
  36    change_privileges($user,$group) if defined $user && defined $group;
  37    return $pid = $$;
  38  }
  39
  40  sub become_daemon {
  41    croak "Can't fork" unless defined (my $child = fork);
  42    exit 0 if $child;    # parent dies;
  43    POSIX::setsid();     # become session leader
  44    open(STDIN,"</dev/null");
  45    open(STDOUT,">/dev/null");
  46    open(STDERR,">&STDOUT");
  47    $CWD = getcwd;       # remember working directory
  48    chdir '/';           # change working directory
  49    umask(0);            # forget file mode creation mask
  50    $ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/bin';
  51    delete @ENV{'IFS', 'CDPATH', 'ENV', 'BASH_ENV'};
  52    $SIG{CHLD} = \&reap_child;
  53  }
  54
  55  sub change_privileges {
  56    my ($user,$group) = @_;
  57    my $uid = getpwnam($user)  or die "Can't get uid for $user\n";
  58    my $gid = getgrnam($group) or die "Can't get gid for $group\n";
  59    $) = "$gid $gid";
  60    $( = $gid;
  61    $> = $uid;   # change the effective UID (but not the real UID)
  62  }
  63
  64  sub launch_child {
  65    my $callback = shift;
  66    my $home     = shift;
  67    my $signals = POSIX::SigSet->new(SIGINT,SIGCHLD,SIGTERM,SIGHUP);
  68    sigprocmask(SIG_BLOCK,$signals);  # block inconvenient signals
  69    log_die("Can't fork: $!") unless defined (my $child = fork());
  70    if ($child) {
  71      $CHILDREN{$child} = $callback || 1;
  72    } else {
  73      $SIG{HUP} = $SIG{INT} = $SIG{CHLD} = $SIG{TERM} = 'DEFAULT';
  74      prepare_child($home);
  75    }
  76    sigprocmask(SIG_UNBLOCK,$signals);  # unblock signals
  77    return $child;
  78  }
  79
  80  sub prepare_child {
  81    my $home = shift;
  82    if ($home) {
  83      local($>,$<) = ($<,$>);   # become root again (briefly)
  84      chdir  $home || croak "chdir(): $!";
  85      chroot $home || croak "chroot(): $!";
  86    }
  87    $< = $>;  # set real UID to effective UID
  88  }
  89
  90  sub reap_child {
  91    while ( (my $child = waitpid(-1,WNOHANG)) > 0) {
  92      $CHILDREN{$child}->($child) if ref $CHILDREN{$child} eq 'CODE';
  93      delete $CHILDREN{$child};
  94    }
  95  }
  96
  97  sub kill_children {
  98    kill TERM => keys %CHILDREN;
  99    # wait until all the children die
 100    sleep while %CHILDREN;
 101  }
 102
 103  sub do_relaunch {
 104    $> = $<;  # regain privileges
 105    chdir $1 if $CWD =~ m!([./a-zA-z0-9_-]+)!;
 106    croak "bad program name" unless $0 =~ m!([./a-zA-z0-9_-]+)!;
 107    my $program = $1;
 108    my $port = $1 if $ARGV[0] =~ /(\d+)/;
 109    unlink $pidfile;
 110    exec 'perl','-T',$program,$port or croak "Couldn't exec: $!";
 111  }
 112
 113  sub init_log {
 114    setlogsock('unix');
 115    my $basename = basename($0);
 116    openlog($basename,'pid',FACILITY);
 117    $SIG{__WARN__} = \&log_warn;
 118    $SIG{__DIE__}  = \&log_die;
 119  }
 120
 121  sub log_debug  { syslog('debug',_msg(@_))  }
 122  sub log_notice { syslog('notice',_msg(@_)) }
 123  sub log_warn   { syslog('warning',_msg(@_))   }
 124  sub log_die {
 125    syslog('crit',_msg(@_)) unless $^S;
 126    die @_;
 127  }
 128  sub _msg {
 129    my $msg = join('',@_) || "Something's wrong";
 130    my ($pack,$filename,$line) = caller(1);
 131    $msg .= " at $filename line $line\n" unless $msg =~ /\n$/;
 132    $msg;
 133  }
 134
 135  sub getpidfilename {
 136    my $basename = basename($0,'.pl');
 137    return PIDPATH . "/$basename.pid";
 138  }
 139
 140  sub open_pid_file {
 141    my $file = shift;
 142    if (-e $file) {  # oops.  pid file already exists
 143      my $fh = IO::File->new($file) || return;
 144      my $pid = <$fh>;
 145      croak "Invalid PID file" unless $pid =~ /^(\d+)$/;
 146      croak "Server already running with PID $1" if kill 0 => $1;
 147      cluck "Removing PID file for defunct server process $pid.\n";
 148      croak"Can't unlink PID file $file" unless -w $file && unlink $file;
 149    }
 150    return IO::File->new($file,O_WRONLY|O_CREAT|O_EXCL,0644)
 151      or die "Can't create $file: $!\n";
 152  }
 153
 154  END {
 155    $> = $<;  # regain privileges
 156    unlink $pidfile if defined $pid and $$ == $pid
 157  }
 158
 159  1;
 160  __END__

Ejecución

root@beowulf:/home/casiano/src/perl/serverwithhup# ps -fA | grep eliza
nobody    1404     1  0 18:54 ?        00:00:00 /usr/bin/perl -w -T ./eliza_hup.pl
root      1406 16664  0 18:54 pts/0    00:00:00 grep eliza
root@beowulf:/home/casiano/src/perl/serverwithhup# telnet localhost 1200
Trying 127.0.0.1...
Connected to localhost.localdomain.
Escape character is '^]'.
Eliza:  Please tell me what's been bothering you.
you:    bye
Eliza:  I think you should talk to a REAL analyst.  Ciao!
Connection closed by foreign host.

Subsecciones

- El Módulo de Soporte
- Ejecución

Casiano Rodríguez León

Programación Distribuida y Mejora del Rendimiento
por Casiano Rodríguez León is licensed under a Creative Commons Reconocimiento 3.0 Unported License.

Permissions beyond the scope of this license may be available at http://campusvirtual.ull.es/ocw/course/view.php?id=44.
2012-06-19