3 # based on http://www.perlmonks.org/?node_id=582781 by Justin Hawkins
6 # modules and variables, oh my
12 #use SOAP::Transport::HTTP;
13 use XMLRPC::Transport::HTTP;
14 use XMLRPC::Lite; # for XMLRPC::Serializer
16 use POE; # Base features.
17 use POE::Filter::HTTPD; # For serving HTTP content.
18 use POE::Wheel::ReadWrite; # For socket I/O.
19 use POE::Wheel::SocketFactory; # For serving socket connections.
21 use FS::UID qw(adminsuidsetup);
22 #use FS::SelfService::XMLRPC;
23 use FS::ClientAPI qw( load_clientapi_modules );
24 use FS::ClientAPI_XMLRPC;
27 #sub DEBUG () { 0 } # Enable a lot of runtime information.
28 #sub MAX_PROCESSES () { 10 } # Total number of server processes.
29 #sub SERVER_PORT () { 8092 } # Server port to listen on.
30 sub DEBUG () { 0 } # Enable a lot of runtime information.
31 sub MAX_PROCESSES () { 32 } # Total number of server processes.
32 sub SERVER_PORT () { 8080 } # Server port to listen on.
34 sub TESTING_CHURN () { 0 } # Randomly shutdown children to test respawn.
38 base64 => [10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/}, 'as_base64'],
39 dateTime => [35, sub {$_[0] =~ /^\d{8}T\d\d:\d\d:\d\d$/}, 'as_dateTime'],
40 string => [40, sub {1}, 'as_string'],
43 # These are HTTP::Request headers that have methods.
45 qw( authorization authorization_basic
46 content content_encoding content_language content_length content_type
47 date expires from if_modified_since if_unmodified_since last_modified
48 method protocol proxy_authorization proxy_authorization_basic referer
49 server title url user_agent www_authenticate
52 # These are HTTP::Request headers that do not have methods.
54 qw( username opaque stale algorithm realm uri qop auth nonce cnonce
62 my $user = shift or die &usage;
65 load_clientapi_modules;
71 # Spawn up to MAX_PROCESSES server processes, and then run them. Exit
74 server_spawn(MAX_PROCESSES);
77 #XXX we probably want to sleep a bit and then try all over again...
84 ### Spawn the main server. This will run as the parent process.
87 my ($max_processes) = @_;
91 { _start => \&server_start,
92 _stop => \&server_stop,
93 do_fork => \&server_do_fork,
94 got_error => \&server_got_error,
95 got_sig_int => \&server_got_sig_int,
96 got_sig_chld => \&server_got_sig_chld,
97 got_connection => \&server_got_connection,
102 { max_processes => $max_processes,
107 ### The main server session has started. Set up the server socket and
108 ### bookkeeping information, then fork the initial child processes.
111 my ( $kernel, $heap ) = @_[ KERNEL, HEAP ];
113 $heap->{server} = POE::Wheel::SocketFactory->new
114 ( BindPort => SERVER_PORT,
115 SuccessEvent => "got_connection",
116 FailureEvent => "got_error",
120 $kernel->sig( CHLD => "got_sig_chld" );
121 $kernel->sig( INT => "got_sig_int" );
123 $heap->{children} = {};
124 $heap->{is_a_child} = 0;
126 warn "Server $$ has begun listening on port ", SERVER_PORT, "\n";
128 $kernel->yield("do_fork");
131 ### The server session has shut down. If this process has any
132 ### children, signal them to shutdown too.
136 DEBUG and warn "Server $$ stopped.\n";
137 if ( my @children = keys %{ $heap->{children} } ) {
138 DEBUG and warn "Server $$ is signaling children to stop.\n";
139 kill INT => @children;
143 ### The server session has encountered an error. Shut it down.
145 sub server_got_error {
146 my ( $heap, $syscall, $errno, $error ) = @_[ HEAP, ARG0 .. ARG2 ];
147 warn( "Server $$ got $syscall error $errno: $error\n",
148 "Server $$ is shutting down.\n",
150 delete $heap->{server};
153 ### The server has a need to fork off more children. Only honor that
154 ### request form the parent, otherwise we would surely "forkbomb".
155 ### Fork off as many child processes as we need.
158 my ( $kernel, $heap ) = @_[ KERNEL, HEAP ];
160 return if $heap->{is_a_child};
162 my $current_children = keys %{ $heap->{children} };
163 for ( $current_children + 2 .. $heap->{max_processes} ) {
165 DEBUG and warn "Server $$ is attempting to fork.\n";
169 unless ( defined($pid) ) {
171 warn( "Server $$ fork failed: $!\n",
172 "Server $$ will retry fork shortly.\n",
174 $kernel->delay( do_fork => 1 );
178 # Parent. Add the child process to its list.
180 $heap->{children}->{$pid} = 1;
184 # Child. Clear the child process list.
185 DEBUG and warn "Server $$ forked successfully.\n";
186 $heap->{is_a_child} = 1;
187 $heap->{children} = {};
193 ### The server session received SIGINT. Don't handle the signal,
194 ### which in turn will trigger the process to exit gracefully.
196 sub server_got_sig_int {
197 DEBUG and warn "Server $$ received SIGINT.\n";
201 ### The server session received a SIGCHLD, indicating that some child
202 ### server has gone away. Remove the child's process ID from our
203 ### list, and trigger more fork() calls to spawn new children.
205 sub server_got_sig_chld {
206 my ( $kernel, $heap, $child_pid ) = @_[ KERNEL, HEAP, ARG1 ];
208 if ( delete $heap->{children}->{$child_pid} ) {
209 DEBUG and warn "Server $$ received SIGCHLD.\n";
210 $kernel->yield("do_fork");
215 ### The server session received a connection request. Spawn off a
216 ### client handler session to parse the request and respond to it.
218 sub server_got_connection {
219 my ( $heap, $socket, $peer_addr, $peer_port ) = @_[ HEAP, ARG0, ARG1, ARG2 ];
221 DEBUG and warn "Server $$ received a connection.\n";
225 { _start => \&client_start,
226 _stop => \&client_stop,
227 got_request => \&client_got_request,
228 got_flush => \&client_flushed_request,
229 got_error => \&client_got_error,
230 _parent => sub { 0 },
234 peer_addr => $peer_addr,
235 peer_port => $peer_port,
239 delete $heap->{server}
240 if TESTING_CHURN and $heap->{is_a_child} and ( rand() < 0.1 );
243 ### The client handler has started. Wrap its socket in a ReadWrite
244 ### wheel to begin interacting with it.
249 $heap->{client} = POE::Wheel::ReadWrite->new
250 ( Handle => $heap->{socket},
251 Filter => POE::Filter::HTTPD->new(),
252 InputEvent => "got_request",
253 ErrorEvent => "got_error",
254 FlushedEvent => "got_flush",
257 DEBUG and warn "Client handler $$/", $_[SESSION]->ID, " started.\n";
260 ### The client handler has stopped. Log that fact.
263 DEBUG and warn "Client handler $$/", $_[SESSION]->ID, " stopped.\n";
266 ### The client handler has received a request. If it's an
267 ### HTTP::Response object, it means some error has occurred while
268 ### parsing the request. Send that back and return immediately.
269 ### Otherwise parse and process the request, generating and sending an
270 ### HTTP::Response object in response.
272 sub client_got_request {
273 my ( $heap, $request ) = @_[ HEAP, ARG0 ];
277 my $serializer = new XMLRPC::Serializer(typelookup => \%typelookup);
279 #my $soap = SOAP::Transport::HTTP::Server
280 my $soap = XMLRPC::Transport::HTTP::Server
282 -> dispatch_to('FS::ClientAPI_XMLRPC')
283 -> serializer($serializer);
286 warn "Client handler $$/", $_[SESSION]->ID, " is handling a request.\n";
288 if ( $request->isa("HTTP::Response") ) {
289 $heap->{client}->put($request);
293 $soap->request($request);
295 my $response = $soap->response;
297 $heap->{client}->put($response);
300 #setup the database connection and other things FS::SelfService::XMLRPC
301 #expects to be in place. aka "kid time" in freeside-selfservice-server
302 sub freeside_kid_time {
304 #if we need a db connection in the parent
306 #$FS::UID::dbh->{InactiveDestroy} = 1;
307 #forksuidsetup($user);
309 adminsuidsetup($user);
314 ### The client handler received an error. Stop the ReadWrite wheel,
315 ### which also closes the socket.
317 sub client_got_error {
318 my ( $heap, $operation, $errnum, $errstr ) = @_[ HEAP, ARG0, ARG1, ARG2 ];
320 warn( "Client handler $$/", $_[SESSION]->ID,
321 " got $operation error $errnum: $errstr\n",
322 "Client handler $$/", $_[SESSION]->ID, " is shutting down.\n"
324 delete $heap->{client};
327 ### The client handler has flushed its response to the socket. We're
328 ### done with the client connection, so stop the ReadWrite wheel.
330 sub client_flushed_request {
333 warn( "Client handler $$/", $_[SESSION]->ID,
334 " flushed its response.\n",
335 "Client handler $$/", $_[SESSION]->ID, " is shutting down.\n"
337 delete $heap->{client};
341 die "Usage:\n\n freeside-selfservice-xmlrpcd user\n";