fix customer package browse selection, RT#39822
[freeside.git] / 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;