FS/bin/freeside-selfservice-xmlrpcd

   1 #!/usr/bin/perl
   2 #
   3 # based on http://www.perlmonks.org/?node_id=582781 by Justin Hawkins
   4 # and http://poe.perl.org/?POE_Cookbook/Web_Server_With_Forking
   5
   6 ###
   7 # modules and constants and variables, oh my
   8 ###
   9
  10 use warnings;
  11 use strict;
  12
  13 use constant DEBUG         => 1;       # Enable much runtime information.
  14 use constant MAX_PROCESSES => 10;      # Total server process count.
  15 use constant SERVER_PORT   => 8080;    # Server port.
  16 use constant TESTING_CHURN => 0;       # Randomly test process respawning.
  17
  18 use POE;                         # Base features.
  19 use POE::Filter::HTTPD;          # For serving HTTP content.
  20 use POE::Wheel::ReadWrite;       # For socket I/O.
  21 use POE::Wheel::SocketFactory;   # For serving socket connections.
  22
  23 #use SOAP::Transport::HTTP;
  24 use XMLRPC::Transport::HTTP;
  25 use XMLRPC::Lite; # for XMLRPC::Serializer
  26
  27 use FS::UID qw(adminsuidsetup);
  28 #use FS::SelfService::XMLRPC;
  29 use FS::ClientAPI qw( load_clientapi_modules );
  30 use FS::ClientAPI_XMLRPC;
  31
  32 #xmlrpc.cgi
  33 my %typelookup = (
  34   base64 => [10, sub {$_[0] =~ /[^\x09\x0a\x0d\x20-\x7f]/}, 'as_base64'],
  35   dateTime => [35, sub {$_[0] =~ /^\d{8}T\d\d:\d\d:\d\d$/}, 'as_dateTime'],
  36   string => [40, sub {1}, 'as_string'],
  37 );
  38
  39 # These are HTTP::Request headers that have methods.
  40 my @method_headers =
  41   qw( authorization authorization_basic
  42   content content_encoding content_language content_length content_type
  43   date expires from if_modified_since if_unmodified_since last_modified
  44   method protocol proxy_authorization proxy_authorization_basic referer
  45   server title url user_agent www_authenticate
  46 );
  47
  48 # These are HTTP::Request headers that do not have methods.
  49 my @header_headers =
  50   qw( username opaque stale algorithm realm uri qop auth nonce cnonce
  51   nc response
  52 );
  53
  54 ###
  55 # init
  56 ###
  57
  58 my $user = shift or die &usage;
  59
  60 #FS::ClientAPI
  61 load_clientapi_modules;
  62
  63 ###
  64 # the main loop
  65 ###
  66
  67 # Spawn up to MAX_PROCESSES server processes, and then run them.  Exit
  68 # when they are done.
  69
  70 server_spawn(MAX_PROCESSES);
  71 POE::Kernel->run();
  72
  73 #XXX we probably want to sleep a bit and then try all over again...
  74 exit 0;
  75
  76 ###
  77 # the subroutines
  78 ###
  79
  80 ### Spawn the main server.  This will run as the parent process.
  81
  82 sub server_spawn {
  83     my ($max_processes) = @_;
  84
  85     POE::Session->create(
  86       inline_states => {
  87         _start         => \&server_start,
  88         _stop          => \&server_stop,
  89         do_fork        => \&server_do_fork,
  90         got_error      => \&server_got_error,
  91         got_sig_int    => \&server_got_sig_int,
  92         got_sig_child  => \&server_got_sig_child,
  93         got_connection => \&server_got_connection,
  94         _child         => sub { undef },
  95       },
  96       heap => { max_processes => MAX_PROCESSES },
  97     );
  98 }
  99
 100 ### The main server session has started.  Set up the server socket and
 101 ### bookkeeping information, then fork the initial child processes.
 102
 103 sub server_start {
 104     my ( $kernel, $heap ) = @_[ KERNEL, HEAP ];
 105
 106     $heap->{server} = POE::Wheel::SocketFactory->new
 107       ( BindPort => SERVER_PORT,
 108         SuccessEvent => "got_connection",
 109         FailureEvent => "got_error",
 110         Reuse        => "yes",
 111       );
 112
 113     #XXX?#$kernel->sig( CHLD => "got_sig_child" );
 114     $kernel->sig( INT  => "got_sig_int" );
 115
 116     $heap->{children}   = {};
 117     $heap->{is_a_child} = 0;
 118
 119     warn "Server $$ has begun listening on port ", SERVER_PORT, "\n";
 120
 121     $kernel->yield("do_fork");
 122 }
 123
 124 ### The server session has shut down.  If this process has any
 125 ### children, signal them to shutdown too.
 126
 127 sub server_stop {
 128     my $heap = $_[HEAP];
 129     DEBUG and warn "Server $$ stopped.\n";
 130
 131     #XXX?
 132     #if ( my @children = keys %{ $heap->{children} } ) {
 133     #    DEBUG and warn "Server $$ is signaling children to stop.\n";
 134     #    kill INT => @children;
 135     #}
 136 }
 137
 138 ### The server session has encountered an error.  Shut it down.
 139
 140 sub server_got_error {
 141     my ( $heap, $syscall, $errno, $error ) = @_[ HEAP, ARG0 .. ARG2 ];
 142       warn( "Server $$ got $syscall error $errno: $error\n",
 143         "Server $$ is shutting down.\n",
 144       );
 145     delete $heap->{server};
 146 }
 147
 148 ### The server has a need to fork off more children.  Only honor that
 149 ### request form the parent, otherwise we would surely "forkbomb".
 150 ### Fork off as many child processes as we need.
 151
 152 sub server_do_fork {
 153     my ( $kernel, $heap ) = @_[ KERNEL, HEAP ];
 154
 155     return if $heap->{is_a_child};
 156
 157     #my $current_children = keys %{ $heap->{children} };
 158     #for ( $current_children + 2 .. $heap->{max_processes} ) {
 159     while (scalar(keys %{$heap->{children}}) < $heap->{max_processes}) {
 160
 161         DEBUG and warn "Server $$ is attempting to fork.\n";
 162
 163         my $pid = fork();
 164
 165         unless ( defined($pid) ) {
 166             DEBUG and
 167               warn( "Server $$ fork failed: $!\n",
 168                 "Server $$ will retry fork shortly.\n",
 169               );
 170             $kernel->delay( do_fork => 1 );
 171             return;
 172         }
 173
 174         # Parent.  Add the child process to its list.
 175         if ($pid) {
 176             $heap->{children}->{$pid} = 1;
 177             $kernel->sig_child($pid, "got_sig_child");
 178             next;
 179         }
 180
 181         # Child.  Clear the child process list.
 182         $kernel->has_forked();
 183         DEBUG and warn "Server $$ forked successfully.\n";
 184         $heap->{is_a_child} = 1;
 185         $heap->{children}   = {};
 186
 187         return;
 188     }
 189 }
 190
 191 ### The server session received SIGINT.  Don't handle the signal,
 192 ### which in turn will trigger the process to exit gracefully.
 193
 194 sub server_got_sig_int {
 195     DEBUG and warn "Server $$ received SIGINT.\n";
 196     delete $_[HEAP]->{server};
 197     $_[KERNEL]->sig_handled();
 198 }
 199
 200 ### The server session received a SIGCHLD, indicating that some child
 201 ### server has gone away.  Remove the child's process ID from our
 202 ### list, and trigger more fork() calls to spawn new children.
 203
 204 sub server_got_sig_child {
 205     my ( $kernel, $heap, $child_pid ) = @_[ KERNEL, HEAP, ARG1 ];
 206
 207     return unless delete $heap->{children}->{$child_pid};
 208
 209    DEBUG and warn "Server $$ reaped child $child_pid.\n";
 210    $kernel->yield("do_fork") if exists $_[HEAP]->{server};
 211 }
 212
 213 ### The server session received a connection request.  Spawn off a
 214 ### client handler session to parse the request and respond to it.
 215
 216 sub server_got_connection {
 217     my ( $heap, $socket, $peer_addr, $peer_port ) = @_[ HEAP, ARG0, ARG1, ARG2 ];
 218
 219     DEBUG and warn "Server $$ received a connection.\n";
 220
 221     POE::Session->create(
 222       inline_states => {
 223         _start      => \&client_start,
 224         _stop       => \&client_stop,
 225         got_request => \&client_got_request,
 226         got_flush   => \&client_flushed_request,
 227         got_error   => \&client_got_error,
 228         _parent     => sub { 0 },
 229       },
 230       heap => {
 231         socket    => $socket,
 232         peer_addr => $peer_addr,
 233         peer_port => $peer_port,
 234       },
 235     );
 236
 237     # Gracefully exit if testing process churn.
 238     delete $heap->{server}
 239       if TESTING_CHURN and $heap->{is_a_child} and ( rand() < 0.1 );
 240 }
 241
 242 ### The client handler has started.  Wrap its socket in a ReadWrite
 243 ### wheel to begin interacting with it.
 244
 245 sub client_start {
 246     my $heap = $_[HEAP];
 247
 248     $heap->{client} = POE::Wheel::ReadWrite->new
 249       ( Handle => $heap->{socket},
 250         Filter       => POE::Filter::HTTPD->new(),
 251         InputEvent   => "got_request",
 252         ErrorEvent   => "got_error",
 253         FlushedEvent => "got_flush",
 254       );
 255
 256     DEBUG and warn "Client handler $$/", $_[SESSION]->ID, " started.\n";
 257 }
 258
 259 ### The client handler has stopped.  Log that fact.
 260
 261 sub client_stop {
 262     DEBUG and warn "Client handler $$/", $_[SESSION]->ID, " stopped.\n";
 263 }
 264
 265 ### The client handler has received a request.  If it's an
 266 ### HTTP::Response object, it means some error has occurred while
 267 ### parsing the request.  Send that back and return immediately.
 268 ### Otherwise parse and process the request, generating and sending an
 269 ### HTTP::Response object in response.
 270
 271 sub client_got_request {
 272     my ( $heap, $request ) = @_[ HEAP, ARG0 ];
 273
 274     freeside_kid_time();
 275
 276     my $serializer = new XMLRPC::Serializer(typelookup => \%typelookup);
 277
 278     #my $soap = SOAP::Transport::HTTP::Server
 279     my $soap = XMLRPC::Transport::HTTP::Server
 280                -> new
 281                -> dispatch_to('FS::ClientAPI_XMLRPC')
 282                -> serializer($serializer);
 283
 284     DEBUG and
 285       warn "Client handler $$/", $_[SESSION]->ID, " is handling a request.\n";
 286
 287     if ( $request->isa("HTTP::Response") ) {
 288         $heap->{client}->put($request);
 289         return;
 290     }
 291
 292     $soap->request($request);
 293     $soap->handle;
 294     my $response = $soap->response;
 295
 296     $heap->{client}->put($response);
 297 }
 298
 299 #setup the database connection and other things FS::SelfService::XMLRPC
 300 #expects to be in place.  aka "kid time" in freeside-selfservice-server
 301 sub freeside_kid_time {
 302
 303   #if we need a db connection in the parent
 304   ##get new db handle
 305   #$FS::UID::dbh->{InactiveDestroy} = 1;
 306   #forksuidsetup($user);
 307
 308   adminsuidsetup($user);
 309
 310   #i guess that was it
 311 }
 312
 313 ### The client handler received an error.  Stop the ReadWrite wheel,
 314 ### which also closes the socket.
 315
 316 sub client_got_error {
 317     my ( $heap, $operation, $errnum, $errstr ) = @_[ HEAP, ARG0, ARG1, ARG2 ];
 318     DEBUG and
 319       warn( "Client handler $$/", $_[SESSION]->ID,
 320         " got $operation error $errnum: $errstr\n",
 321         "Client handler $$/", $_[SESSION]->ID, " is shutting down.\n"
 322       );
 323     delete $heap->{client};
 324 }
 325
 326 ### The client handler has flushed its response to the socket.  We're
 327 ### done with the client connection, so stop the ReadWrite wheel.
 328
 329 sub client_flushed_request {
 330     my $heap = $_[HEAP];
 331     DEBUG and
 332       warn( "Client handler $$/", $_[SESSION]->ID,
 333         " flushed its response.\n",
 334         "Client handler $$/", $_[SESSION]->ID, " is shutting down.\n"
 335       );
 336     delete $heap->{client};
 337 }
 338
 339 sub usage {
 340   die "Usage:\n\n  freeside-selfservice-xmlrpcd user\n";
 341 }
 342
 343 ###
 344 # the end
 345 ###
 346
 347 1;