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