perl/lib/Thrasher.pm

   1 package Thrasher;
   2
   3 use strict;
   4 use warnings;
   5
   6 our $VERSION = '0.1';
   7
   8 =pod
   9
  10 =head1 NAME
  11
  12 Thrasher - top-level module for Thrasher Bird
  13
  14 =head1 SYNOPSIS
  15
  16 In the thrasherbird.pl file:
  17
  18  use Thrasher;
  19  Thrasher::start($backend, $protocol, $server_ip, $server_port,
  20                  $server_secret);
  21
  22 =head1 DESCRIPTION
  23
  24 The Thrasher module stores a few misc. functions that don't belong
  25 anywhere else, and also has the C<start> function, which ties
  26 together all of the pieces and actually starts the transport
  27 functioning.
  28
  29 To learn how to write a new Protocol for Thrasher, see
  30 L<Thrasher::Protocol>.
  31
  32 To learn how to write a new Backend for Thrasher, see
  33 L<Thrasher::Backend>.
  34
  35 =cut
  36
  37 use Thrasher::Socket;
  38 use Thrasher::Callbacks qw(callbacks);
  39 use Thrasher::Component;
  40 use Thrasher::Log qw(logger debug log);
  41
  42 our $SERVER_NAME;
  43 # Item -> discovery info for each item as [$identities, $features],
  44 # created by the component after it finishes connecting
  45 our $SERVER_INFO = {};
  46
  47 our $event_loop;
  48
  49 sub start {
  50     my $backend = shift() || 'Test';
  51     my $backend_module = "Thrasher::Backend::$backend";
  52     my $protocol = (shift() || 'Test');
  53     my $protocol_module = "Thrasher::Protocol::$protocol";
  54     my $server_ip = shift;
  55     my $server_port = shift;
  56     my $server_secret = shift;
  57     my $backend_configuration = shift || {};
  58     my $protocol_configuration = shift || {};
  59     my $component_name_base = shift;
  60     $SERVER_NAME = shift;
  61     my $plugins = shift || [];
  62
  63     my $event_loop_module;
  64
  65     VALIDATE_PARAMETERS: {
  66         local $@;
  67         eval "use $backend_module;";
  68         if ($@) {
  69             print "While trying to load the $backend backend, an error\n"
  70                 ."was encountered. The developers will want to know about\n"
  71                 ."the following:\n\n$@\n";
  72             exit;
  73         }
  74
  75         eval "use $protocol_module;";
  76         if ($@) {
  77             print "While trying to load the $protocol protocol, an error\n"
  78                 ."was encountered. The developers will want to know about\n"
  79                 ."the following:\n\n$@\n";
  80             exit;
  81         }
  82
  83         if (!defined($server_ip)) {
  84             print "Missing server specification (\$server_ip in the "
  85                 ."configuration file).\n";
  86             exit;
  87         }
  88
  89         if (!defined($server_port)) {
  90             print "Missing server port specification (\$server_port "
  91                 ."in the configuration file).\n";
  92             exit;
  93         }
  94         if ($server_port == 0 ||
  95             $server_port < 0 ||
  96             $server_port > 65536 ||
  97             int($server_port) ne $server_port) {
  98             print "Invalid port specification: $server_port\n";
  99             exit;
 100         }
 101
 102         $component_name_base =~ s/^\.//;
 103         if (!$component_name_base) {
 104             print "Component name base (\$component_name_base) must not be empty.\n";
 105             exit;
 106         }
 107
 108         $event_loop_module = $protocol_module->event_loop;
 109         eval "use $event_loop_module;";
 110         if ($@) {
 111             print "While trying to load $event_loop_module, an error\n"
 112                 ."was encountered. The developers will want to know\n"
 113                 ."the following:\n\n$@";
 114             exit;
 115         }
 116
 117         for my $plugin_module (@{$plugins}) {
 118             eval("use ${plugin_module};");
 119             if ($@) {
 120                 print
 121                   "While trying to load the $plugin_module plugin, an error\n"
 122                   . " was encountered. The developers will want to know about\n"
 123                   . " the following:\n\n$@\n";
 124                 exit(1);
 125             }
 126         }
 127     }
 128
 129     my $retry = 0;
 130     my $previous_error;
 131     my $sequential_errors = 0;
 132     logger("Start connection process for PID $$");
 133     while (1) {
 134         local $@ = '';
 135
 136         # This sets up all the plumbing and starts the component
 137         # running.
 138         eval {
 139             debug("About to call $backend_module->new");
 140             my $backend =
 141                 $backend_module->new($backend_configuration);
 142             debug("Got a backend back: $backend");
 143             debug("About to call $protocol_module->new");
 144             my $protocol =
 145                 $protocol_module->new($protocol_configuration,
 146                                       $backend);
 147             debug("Got a protocol: $protocol");
 148             $backend->register_protocol($protocol);
 149             my $component_name = $protocol->identifier;
 150             if (!$component_name) {
 151                 die "Protocol $protocol_module does not give "
 152                     ."us an identifier to use with the component.";
 153             }
 154             $component_name .= '.' . $component_name_base;
 155
 156             $event_loop = $event_loop_module->new();
 157
 158             my $socket = new Thrasher::Socket($server_ip,
 159                                               $server_port,
 160                                               $event_loop);
 161             $socket->connect;
 162             my $write_function = $socket->write_function;
 163
 164             my $component = new Thrasher::Component
 165                 ($protocol, $write_function, $server_secret,
 166                  $component_name);
 167             $component->{event_loop} = $event_loop;
 168             $component->{thrasher_socket} = $socket;
 169             $socket->{read_closure} =
 170                 $component->socket_in_closure($socket);
 171             $socket->establish_fd_watch;
 172
 173             $protocol->{component} = $component;
 174             $backend->{component} = $component;
 175
 176             $component->output_initial_stream_tag;
 177
 178             my $kill_thrasher = sub {
 179                 logger("SIGINT received, shutting down.");
 180                 $component->terminate;
 181                 exit;
 182             };
 183             my $signal_handler = sub {
 184                 $event_loop->execute_on_idle($kill_thrasher);
 185             };
 186             # If the user hits CTRL-C, nicely log people out,
 187             # and allow nice log outs with a signal.
 188             local $SIG{INT} = $signal_handler;
 189             local $SIG{TERM} = $signal_handler;
 190
 191             callbacks('main_loop', $component);
 192
 193             logger("Beginning main event loop.");
 194             $event_loop->go;
 195
 196             $previous_error = '';
 197             $retry = 0;
 198             $sequential_errors = 0;
 199
 200             logger("Main loop terminated.");
 201
 202             # Paranoia, really shouldn't fail
 203             eval { $socket->close(); };
 204         };
 205
 206         if ($@) {
 207             my $error = $@;
 208             $previous_error = $@;
 209
 210             # Suppress repeating log messages: suppress everything but
 211             # the first five errors, and only print every ten minutes
 212             # or so after that, to prove it's still trying
 213             if ($previous_error eq $error) {
 214                 $sequential_errors++;
 215                 my $error_message = "Failed to start transport, retry $retry: $@";
 216                 if ($sequential_errors == 5) {
 217                     logger($error_message);
 218                     # This will be true someday; right now we still
 219                     # want the debugging info.
 220                     logger("Suppressing most errors now; attempts "
 221                            ."will continue until successful.");
 222                 } elsif ($sequential_errors % 60 == 0) {
 223                     logger($error_message);
 224                 } elsif ($sequential_errors < 5) {
 225                     logger($error_message);
 226                 }
 227             } else {
 228                 logger("Failed to connect to server, retry $retry\n");
 229                 logger("Error was: $@\n\n");
 230                 $sequential_errors = 0;
 231             }
 232             sleep 5;
 233             $retry++;
 234             next;
 235         }
 236     }
 237 }
 238
 239 # This currently has nowhere to live...
 240 # If an error makes it back into the SWIG or libpurple layer,
 241 # it is basically destroyed. This catches the error, outputs
 242 # it in the log, and eats it (since the higher layer can't do
 243 # anything useful with it).
 244 sub error_wrap {
 245     my $callback_name = shift;
 246     my $sub_to_wrap = shift;
 247
 248     my $new_sub = sub {
 249         my @args = @_;
 250
 251         undef $@;
 252
 253         # We know there's never any useful return
 254         if (wantarray) {
 255             my @results;
 256             eval { @results = $sub_to_wrap->(@args); };
 257
 258             if ($@) {
 259                 Thrasher::Log::log("Error in $callback_name: $@");
 260             }
 261
 262             return @results;
 263         } else {
 264             my $result;
 265             eval { $result = $sub_to_wrap->(@args); };
 266
 267             if ($@) {
 268                 Thrasher::Log::log("Error in $callback_name: $@");
 269             }
 270
 271             return $result;
 272         }
 273     };
 274
 275     return $new_sub;
 276 }
 277
 278 1;