FS/FS/Daemon/Preforking.pm

   1 package FS::Daemon::Preforking;
   2 use base 'Exporter';
   3
   4 =head1 NAME
   5
   6 FS::Daemon::Preforking - A preforking web server
   7
   8 =head1 SYNOPSIS
   9
  10   use FS::Daemon::Preforking qw( freeside_init1 freeside_init2 daemon_run );
  11
  12   my $me = 'mydaemon'; #keep unique among fs daemons, for logfiles etc.
  13
  14   freeside_init1($me); #daemonize, drop root and connect to freeside
  15
  16   #do setup tasks which should throw an error to the shell starting the daemon
  17
  18   freeside_init2($me); #move logging to logfile and disassociate from terminal
  19
  20   #do setup tasks which will warn/error to the log file, such as declining to
  21   # run if our config is not in place
  22
  23   daemon_run(
  24     'port'           => 5454, #keep unique among fs daemons
  25     'handle_request' => \&handle_request,
  26   );
  27
  28   sub handle_request {
  29     my $request = shift; #HTTP::Request object
  30
  31     #... do your thing
  32
  33     return $response; #HTTP::Response object
  34
  35   }
  36
  37 =head1 AUTHOR
  38
  39 Based on L<http://www.perlmonks.org/?node_id=582781> by Justin Hawkins
  40
  41 and L<http://poe.perl.org/?POE_Cookbook/Web_Server_With_Forking>
  42
  43 =cut
  44
  45 use warnings;
  46 use strict;
  47
  48 use constant DEBUG         => 0;       # Enable much runtime information.
  49 use constant MAX_PROCESSES => 10;      # Total server process count. XXX conf to increase per-different daemon for busy sites using this (currently the only things using this are freeside-xmlrpcd and freeside-selfservice-xmlrpcd)
  50 #use constant TESTING_CHURN => 0;       # Randomly test process respawning.
  51
  52 use vars qw( @EXPORT_OK $FREESIDE_LOG $SERVER_PORT $user $handle_request );
  53 @EXPORT_OK = qw( freeside_init1 freeside_init2 daemon_run );
  54 $FREESIDE_LOG = '%%%FREESIDE_LOG%%%';
  55
  56 use POE 1.2;                     # Base features.
  57 use POE::Filter::HTTPD;          # For serving HTTP content.
  58 use POE::Wheel::ReadWrite;       # For socket I/O.
  59 use POE::Wheel::SocketFactory;   # For serving socket connections.
  60
  61 use FS::Daemon qw( daemonize1 drop_root logfile daemonize2 );
  62 use FS::UID qw( adminsuidsetup forksuidsetup dbh );
  63
  64 #use FS::TicketSystem;
  65
  66 sub freeside_init1 {
  67   my $name = shift;
  68
  69   $user = shift @ARGV or die &usage($name);
  70
  71   $FS::Daemon::NOSIG = 1;
  72   $FS::Daemon::PID_NEWSTYLE = 1;
  73   daemonize1($name);
  74
  75   POE::Kernel->has_forked(); #daemonize forks...
  76
  77   drop_root();
  78
  79   adminsuidsetup($user);
  80 }
  81
  82 sub freeside_init2 {
  83   my $name = shift;
  84
  85   logfile("$FREESIDE_LOG/$name.log");
  86
  87   daemonize2();
  88
  89 }
  90
  91 sub daemon_run {
  92   my %opt = @_;
  93   $SERVER_PORT = $opt{port};
  94   $handle_request = $opt{handle_request};
  95
  96   #parent doesn't need to hold a DB connection open
  97   dbh->disconnect;
  98   undef $FS::UID::dbh;
  99   undef $RT::Handle;
 100
 101   server_spawn(MAX_PROCESSES);
 102   POE::Kernel->run();
 103   #exit;
 104
 105 }
 106
 107 ### Spawn the main server.  This will run as the parent process.
 108
 109 sub server_spawn {
 110     my ($max_processes) = @_;
 111
 112     POE::Session->create(
 113       inline_states => {
 114         _start         => \&server_start,
 115         _stop          => \&server_stop,
 116         do_fork        => \&server_do_fork,
 117         got_error      => \&server_got_error,
 118         got_sig_int    => \&server_got_sig_int,
 119         got_sig_child  => \&server_got_sig_child,
 120         got_connection => \&server_got_connection,
 121         _child         => sub { undef },
 122       },
 123       heap => { max_processes => MAX_PROCESSES },
 124     );
 125 }
 126
 127 ### The main server session has started.  Set up the server socket and
 128 ### bookkeeping information, then fork the initial child processes.
 129
 130 sub server_start {
 131     my ( $kernel, $heap ) = @_[ KERNEL, HEAP ];
 132
 133     $heap->{server} = POE::Wheel::SocketFactory->new
 134       ( BindPort     => $SERVER_PORT,
 135         SuccessEvent => "got_connection",
 136         FailureEvent => "got_error",
 137         Reuse        => "yes",
 138       );
 139
 140     $kernel->sig( INT  => "got_sig_int" );
 141     $kernel->sig( TERM => "got_sig_int" ); #huh
 142
 143     $heap->{children}   = {};
 144     $heap->{is_a_child} = 0;
 145
 146     warn "Server $$ has begun listening on port $SERVER_PORT\n";
 147
 148     $kernel->yield("do_fork");
 149 }
 150
 151 ### The server session has shut down.  If this process has any
 152 ### children, signal them to shutdown too.
 153
 154 sub server_stop {
 155     my $heap = $_[HEAP];
 156     DEBUG and warn "Server $$ stopped.\n";
 157
 158     if ( my @children = keys %{ $heap->{children} } ) {
 159         DEBUG and warn "Server $$ is signaling children to stop.\n";
 160         kill INT => @children;
 161     }
 162 }
 163
 164 ### The server session has encountered an error.  Shut it down.
 165
 166 sub server_got_error {
 167     my ( $heap, $syscall, $errno, $error ) = @_[ HEAP, ARG0 .. ARG2 ];
 168       warn( "Server $$ got $syscall error $errno: $error\n",
 169         "Server $$ is shutting down.\n",
 170       );
 171     delete $heap->{server};
 172 }
 173
 174 ### The server has a need to fork off more children.  Only honor that
 175 ### request form the parent, otherwise we would surely "forkbomb".
 176 ### Fork off as many child processes as we need.
 177
 178 sub server_do_fork {
 179     my ( $kernel, $heap ) = @_[ KERNEL, HEAP ];
 180
 181     return if $heap->{is_a_child};
 182
 183     #my $current_children = keys %{ $heap->{children} };
 184     #for ( $current_children + 2 .. $heap->{max_processes} ) {
 185     while (scalar(keys %{$heap->{children}}) < $heap->{max_processes}) {
 186
 187         DEBUG and warn "Server $$ is attempting to fork.\n";
 188
 189         my $pid = fork();
 190
 191         unless ( defined($pid) ) {
 192             DEBUG and
 193               warn( "Server $$ fork failed: $!\n",
 194                 "Server $$ will retry fork shortly.\n",
 195               );
 196             $kernel->delay( do_fork => 1 );
 197             return;
 198         }
 199
 200         # Parent.  Add the child process to its list.
 201         if ($pid) {
 202             $heap->{children}->{$pid} = 1;
 203             $kernel->sig_child($pid, "got_sig_child");
 204             next;
 205         }
 206
 207         # Child.  Clear the child process list.
 208         $kernel->has_forked();
 209         DEBUG and warn "Server $$ forked successfully.\n";
 210         $heap->{is_a_child} = 1;
 211         $heap->{children}   = {};
 212
 213         #freeside db connection, etc.
 214         forksuidsetup($user);
 215
 216         #why isn't this needed ala freeside-selfservice-server??
 217         #FS::TicketSystem->init();
 218
 219         return;
 220     }
 221 }
 222
 223 ### The server session received SIGINT.  Don't handle the signal,
 224 ### which in turn will trigger the process to exit gracefully.
 225
 226 sub server_got_sig_int {
 227     my ( $kernel, $heap ) = @_[ KERNEL, HEAP ];
 228     DEBUG and warn "Server $$ received SIGINT/TERM.\n";
 229
 230     if ( my @children = keys %{ $heap->{children} } ) {
 231         DEBUG and warn "Server $$ is signaling children to stop.\n";
 232         kill INT => @children;
 233     }
 234
 235     delete $heap->{server};
 236     $kernel->sig_handled();
 237 }
 238
 239 ### The server session received a SIGCHLD, indicating that some child
 240 ### server has gone away.  Remove the child's process ID from our
 241 ### list, and trigger more fork() calls to spawn new children.
 242
 243 sub server_got_sig_child {
 244     my ( $kernel, $heap, $child_pid ) = @_[ KERNEL, HEAP, ARG1 ];
 245
 246     return unless delete $heap->{children}->{$child_pid};
 247
 248    DEBUG and warn "Server $$ reaped child $child_pid.\n";
 249    $kernel->yield("do_fork") if exists $_[HEAP]->{server};
 250 }
 251
 252 ### The server session received a connection request.  Spawn off a
 253 ### client handler session to parse the request and respond to it.
 254
 255 sub server_got_connection {
 256     my ( $heap, $socket, $peer_addr, $peer_port ) = @_[ HEAP, ARG0, ARG1, ARG2 ];
 257
 258     DEBUG and warn "Server $$ received a connection.\n";
 259
 260     POE::Session->create(
 261       inline_states => {
 262         _start      => \&client_start,
 263         _stop       => \&client_stop,
 264         got_request => \&client_got_request,
 265         got_flush   => \&client_flushed_request,
 266         got_error   => \&client_got_error,
 267         _parent     => sub { 0 },
 268       },
 269       heap => {
 270         socket    => $socket,
 271         peer_addr => $peer_addr,
 272         peer_port => $peer_port,
 273       },
 274     );
 275
 276 #    # Gracefully exit if testing process churn.
 277 #    delete $heap->{server}
 278 #      if TESTING_CHURN and $heap->{is_a_child} and ( rand() < 0.1 );
 279 }
 280
 281 ### The client handler has started.  Wrap its socket in a ReadWrite
 282 ### wheel to begin interacting with it.
 283
 284 sub client_start {
 285     my $heap = $_[HEAP];
 286
 287     $heap->{client} = POE::Wheel::ReadWrite->new
 288       ( Handle => $heap->{socket},
 289         Filter       => POE::Filter::HTTPD->new(),
 290         InputEvent   => "got_request",
 291         ErrorEvent   => "got_error",
 292         FlushedEvent => "got_flush",
 293       );
 294
 295     DEBUG and warn "Client handler $$/", $_[SESSION]->ID, " started.\n";
 296 }
 297
 298 ### The client handler has stopped.  Log that fact.
 299
 300 sub client_stop {
 301     DEBUG and warn "Client handler $$/", $_[SESSION]->ID, " stopped.\n";
 302 }
 303
 304 ### The client handler has received a request.  If it's an
 305 ### HTTP::Response object, it means some error has occurred while
 306 ### parsing the request.  Send that back and return immediately.
 307 ### Otherwise parse and process the request, generating and sending an
 308 ### HTTP::Response object in response.
 309
 310 sub client_got_request {
 311     my ( $heap, $request ) = @_[ HEAP, ARG0 ];
 312
 313     DEBUG and
 314       warn "Client handler $$/", $_[SESSION]->ID, " is handling a request.\n";
 315
 316     if ( $request->isa("HTTP::Response") ) {
 317         $heap->{client}->put($request);
 318         return;
 319    }
 320
 321     forksuidsetup($user) unless dbh && dbh->ping;
 322
 323     my $response = &{ $handle_request }( $request );
 324
 325     $heap->{client}->put($response);
 326 }
 327
 328 ### The client handler received an error.  Stop the ReadWrite wheel,
 329 ### which also closes the socket.
 330
 331 sub client_got_error {
 332     my ( $heap, $operation, $errnum, $errstr ) = @_[ HEAP, ARG0, ARG1, ARG2 ];
 333     DEBUG and
 334       warn( "Client handler $$/", $_[SESSION]->ID,
 335         " got $operation error $errnum: $errstr\n",
 336         "Client handler $$/", $_[SESSION]->ID, " is shutting down.\n"
 337       );
 338     delete $heap->{client};
 339 }
 340
 341 ### The client handler has flushed its response to the socket.  We're
 342 ### done with the client connection, so stop the ReadWrite wheel.
 343
 344 sub client_flushed_request {
 345     my $heap = $_[HEAP];
 346     DEBUG and
 347       warn( "Client handler $$/", $_[SESSION]->ID,
 348         " flushed its response.\n",
 349         "Client handler $$/", $_[SESSION]->ID, " is shutting down.\n"
 350       );
 351     delete $heap->{client};
 352 }
 353
 354 sub usage {
 355   my $name = shift;
 356   die "Usage:\n\n  freeside-$name user\n";
 357 }
 358
 359 1;