perl/lib/Thrasher/Protocol/Purple.pm

   1 package Thrasher::Protocol::Purple;
   2 use strict;
   3 use warnings;
   4
   5 =head1 NAME
   6
   7 Thrasher::Protocol::Purple - test protocol for Thrasher Bird
   8
   9 =head1 DESCRIPTION
  10
  11 This package is the base class for protocols using libpurple.
  12 Each protocol may have slightly different details w.r.t. how they work
  13 with Thrasher, which is handled by specializing them further,
  14 such as with Thrasher::Protocol::Purple::AIM. As you find such
  15 differences, please be sure to add hooks in here, not hack on
  16 this module directly.
  17
  18 =cut
  19
  20 use base 'Thrasher::Protocol';
  21
  22 use Thrasher::Component qw(strip_resource);
  23 use Thrasher::Log qw(log logger debug);
  24 use Thrasher::Roster;
  25 use Thrasher::Session;
  26 use Thrasher::XMPPStreamIn;
  27 use Glib qw(G_PRIORITY_DEFAULT);
  28 use Carp qw(confess);
  29 use Data::Dumper;
  30 use Switch;
  31 use Encode;
  32
  33 use Thrasher::Protocol::Purple::Vars qw(:all);
  34 use THPPW;
  35
  36 # Plugins we use
  37 use Thrasher::Plugin::Vcard;
  38 use Thrasher::Plugin::EntityCapabilities;
  39
  40 my $DEBUG = 1;
  41
  42 # Internal debugging
  43 THPPW::thrasher_purple_debug($DEBUG);
  44
  45 # Initialize the wrapper
  46 THPPW::thrasher_wrapper_init
  47     (Thrasher::error_wrap("timeout_add", \&_timeout_add),
  48      Thrasher::error_wrap("input_add", \&_input_add),
  49      Thrasher::error_wrap("source_remove", \&_source_remove),
  50      Thrasher::error_wrap("incoming_msg", \&_incoming_msg),
  51      Thrasher::error_wrap("presence_in", \&_presence_in),
  52      Thrasher::error_wrap("subscription_add", \&_subscription_add),
  53      Thrasher::error_wrap("legacy_user_adding_user", \&_legacy_user_adding_user),
  54      Thrasher::error_wrap("connection_error", \&_connection_error),
  55      Thrasher::error_wrap("connection", \&_connection),
  56      Thrasher::error_wrap("incoming_chatstate", \&_incoming_chatstate),
  57 );
  58
  59 # Initialize the remainder
  60 THPPW::thrasher_init();
  61
  62 # Globalize component object so we can receive messages
  63 our $global_component;
  64
  65 sub event_loop {
  66     return 'Thrasher::EventLoop::Glib';
  67 }
  68
  69 # This internal routine allows us to group the initial
  70 # subscribe additions and throw them back.
  71 sub _initial_roster {
  72     my $session = shift;
  73
  74     if (! $session || !$session->{'jid'}) {
  75         debug("_initial_roster: No session. Must be post-logoff?");
  76         return 0;
  77     }
  78
  79     debug("_initial_roster($session->{jid}) called\n");
  80
  81     my $roster;
  82
  83     foreach my $username (keys %{$session->{initial_roster}}) {
  84         $username = $session->{protocol}->process_remote_username($username);
  85         $roster->{$username} = Thrasher::Roster::subscribed();
  86         # We should also handle presence info here (?)
  87     }
  88
  89     $session->{protocol}->set_current_legacy_roster($session, $roster);
  90
  91     delete $session->{initial_roster_timeout_active};
  92     $session->{initial_roster} = [];
  93
  94     # Thrasher can now be sure the protocol is completely online and
  95     # ready to e.g. send IMs queued while login was in progress.
  96     if ($session->{'protocol_state'} eq 'logging in') {
  97         $session->{'protocol'}->set_session_state($session, 'online');
  98     }
  99
 100     # We don't want the timeout to loop, so destroy with 0
 101     return 0;
 102 }
 103
 104 # This appears to only be called for things on our initial roster.
 105 # FIXME: If that's true, change this.
 106 sub _subscription_add {
 107     my $orig_jid    = shift;
 108     my $orig_sender = shift;
 109     my $status = shift;
 110
 111     my $jid = Encode::decode("UTF-8", $orig_jid);
 112     my $sender = Encode::decode("UTF-8", $orig_sender);
 113
 114     debug("_subscription_add($orig_jid, $orig_sender) called\n");
 115
 116     my $session = $global_component->session_for($jid);
 117
 118     # Set a timeout if we have no previous jid information
 119     if (not defined $session->{initial_roster}) {
 120
 121         # Set a flag so we don't push subscription additions
 122         # to an unused array
 123         $session->{initial_roster_timeout_active} = 1;
 124
 125         # Heuristically manage our initial roster as we cannot
 126         # tell when the libpurple protocols are done giving us the
 127         # subscribe user list.
 128         Glib::Timeout->add(5000,
 129                            \&_initial_roster,
 130                            $session,
 131                            G_PRIORITY_DEFAULT);
 132     }
 133
 134     # Verify we're actually within a timeout
 135     if ($session->{initial_roster_timeout_active}) {
 136         # This is a bit ugly, but it allows us to bind sender/status
 137         # info to JIDs for timeouts
 138         $session->{initial_roster}{$sender} = $status;
 139     }
 140     # We aren't in a timeout, we need to send new subscribe info up
 141     else {
 142     }
 143
 144     # Subscription-in information has the presence information
 145     # loaded onto it too, at least for AIM
 146     if ($status) {
 147         _presence_in($orig_jid, $orig_sender, undef, undef, $status);
 148     }
 149
 150     debug("_subscription_add done\n");
 151
 152     return 1;
 153 }
 154
 155 sub _legacy_user_adding_user {
 156     my $jid_target = shift;
 157     my $legacy_username_adding = shift;
 158
 159     $jid_target = Encode::decode("UTF-8", $jid_target);
 160     $legacy_username_adding = Encode::decode("UTF-8", $legacy_username_adding);
 161
 162     log("$legacy_username_adding requesting add for $jid_target");
 163
 164     my $session = $global_component->session_for($jid_target);
 165
 166     if ($session) {
 167         $session->{protocol}->adding_contact($legacy_username_adding,
 168                                              $jid_target);
 169     } else {
 170         log("Got request to add user $jid_target, but $jid_target is "
 171             ."not logged in.");
 172     }
 173 }
 174
 175 sub process_message { return $_[1]; }
 176 sub process_remote_username { return $_[1]; }
 177
 178 # Callback of presence in
 179 sub _presence_in {
 180     my $jid     = shift;
 181     my $sender  = shift;
 182     my $alias   = shift;
 183     my $group   = shift;
 184     my $status  = shift;
 185     my $message = shift;
 186
 187     $jid = Encode::decode("UTF-8", $jid);
 188     $sender = Encode::decode("UTF-8", $sender);
 189     $alias = Encode::decode("UTF-8", $alias);
 190     $group = Encode::decode("UTF-8", $group);
 191     $status = Encode::decode("UTF-8", $status);
 192     $message = Encode::decode("UTF-8", $message);
 193
 194     debug("_presence_in($jid, $sender, $status) called\n");
 195
 196     my $session = $global_component->session_for($jid);
 197     my $self = $session->{protocol};
 198     if (!defined($self)) {
 199         debug("No session defined for $jid, must be post-logoff?");
 200         return 0;
 201     }
 202
 203     my $clean_sender = $self->process_remote_username($sender);
 204
 205     if ($message) {
 206         $message =~ s/([\x80-\xff])/'&#' . ord($1) . ';'/ge;
 207     }
 208
 209     # Nothing is done with protocol?
 210     my $xmpp_presence = $purple_presence_to_xmpp{$status};
 211     if ($xmpp_presence) {
 212         my ($type, $show) = @{$xmpp_presence};
 213         $self->legacy_presence_update($session,
 214                                       $clean_sender,
 215                                       $type,
 216                                       $show,
 217                                       $message);
 218     }
 219     else {
 220         log("Unknown presence status of $status was sent by "
 221             ."$clean_sender to $jid.");
 222         return 0;
 223     }
 224
 225     debug("_presence_in done\n");
 226     return 1;
 227 }
 228
 229 sub _incoming_chatstate {
 230     my ($orig_jid, $orig_sender, $state) = @_;
 231     debug("_incoming_chatstate($orig_jid, $orig_sender, $state) called\n");
 232
 233     my $state_tag;
 234     # loosely <http://xmpp.org/extensions/xep-0085.html>
 235     if ($state == $THPPW::PURPLE_TYPING) {
 236         $state_tag = 'composing';
 237     }
 238     elsif ($state == $THPPW::PURPLE_TYPED) {
 239         $state_tag = 'paused';
 240     }
 241     elsif ($state == $THPPW::PURPLE_NOT_TYPING) {
 242         $state_tag = 'inactive';
 243     }
 244     else {
 245         return;
 246     }
 247
 248     my $jid = Encode::decode('UTF-8', $orig_jid);
 249     my $sender = Encode::decode('UTF-8', $orig_sender);
 250
 251     my $session = $global_component->session_for($jid);
 252     if (! $session) {
 253         debug("No session?!!\n");
 254         return;
 255     }
 256     if (! $session->{'protocol'}) {
 257         debug("No session protocol?!!\n");
 258         return;
 259     }
 260     $session->{'protocol'}->incoming_chatstate($session, $sender, $state_tag);
 261     return;
 262 }
 263
 264 sub _connection {
 265     my ($orig_jid) = @_;
 266     my $jid = Encode::decode("UTF-8", $orig_jid);
 267     debug("_connection($jid) called\n");
 268
 269     my $session = $global_component->session_for($jid);
 270     if (! $session) {
 271         # Component::logout and thrasher.c:thrasher_logout() will
 272         # happily destroy the session and thrasher_connection while
 273         # libpurple is waiting asynchronously for connection events.
 274         # Once the connection completes and libpurple starts firing
 275         # callbacks, weird errors arise because the session is gone
 276         # and Thrasher has lost track of what is connected.
 277         #
 278         # Maybe we should reject the logout and defer it to
 279         # _connection{,_error}, relying on one of them always being
 280         # called eventually?
 281         log("_connection($jid): No session? Assuming already logged out.");
 282         # Ensure the thrasher_connection gets gone.
 283         Glib::Timeout->add(1,
 284                            sub {
 285                                # Log off just after logon finishes, not during.
 286                                #
 287                                # Turns out purple_connection_set_state()
 288                                # (which called the connected ui_op) crashes
 289                                # if prpl_info is yanked out from under it.
 290                                THPPW::thrasher_action_logout($orig_jid);
 291                            },
 292                            undef,
 293                            G_PRIORITY_DEFAULT);
 294         return 1;
 295     }
 296
 297     my $protocol = $session->{'protocol'};
 298     if (! $protocol) {
 299         log("_connection($jid): No protocol?!!");
 300         return 0;
 301     }
 302
 303     $session->{'purple_connection_created'} = 1;
 304     delete($protocol->{'connection_started_at'}->{$jid});
 305     my $continuation = delete($session->{'connection_cb'});
 306     if ($continuation) {
 307         $continuation->($session);
 308     }
 309     else {
 310         log("_connection($jid): No connection_cb?!!");
 311         return 0;
 312     }
 313
 314     # But libpurple prpl might not be ready to send IMs queued during
 315     # login. Wait until _initial_roster() for online protocol_state.
 316     Glib::Timeout->add(
 317         # If after no _subscription_add()/_initial_roster() happens
 318         # (perhaps the account has no current legacy roster at all?)
 319         # ensure session is eventually set online anyway.
 320         15000,
 321         sub {
 322             if (! $session->{'initial_roster_timeout_active'}
 323                   && ! $session->{'initial_roster'}
 324                   && $session->{'protocol_state'} eq 'logging in') {
 325                 debug("Never called _initial_roster($session->{jid})?\n");
 326                 $protocol->set_session_state($session, 'online');
 327             }
 328             return 0; # No repeat
 329         },
 330         undef,
 331         G_PRIORITY_DEFAULT
 332     );
 333
 334     return 1;
 335 }
 336
 337 sub _connection_error {
 338     my $jid        = shift;
 339     my $error_code = shift;
 340     my $message    = shift;
 341
 342     $jid = Encode::decode("UTF-8", $jid);
 343     $message = Encode::decode("UTF-8", $message);
 344
 345     debug("_connection_error($jid)\n");
 346
 347     my $session = $global_component->session_for($jid);
 348     if (! $session) {
 349         log("No session?!! Error was $error_code/'$message'.");
 350         return 0;
 351     }
 352     my $protocol = $session->{protocol};
 353     if ($protocol) {
 354         # Clear connection state.
 355         delete($session->{'connection_cb'});
 356         delete($protocol->{'connection_started_at'}->{$jid});
 357     }
 358     else {
 359         log("_connection($jid): No protocol?!!");
 360         return 0;
 361     }
 362
 363     my $attempt_reconnect = 0;
 364     my $error = '';
 365
 366     if ($session->{status} =~ /disconnecting/) {
 367         log("Got error code $error_code, but ignoring it since "
 368             ."we're in the middle of disconnecting.");
 369         return 1;
 370     }
 371
 372     # Some of these cases are poorly tested since it's either
 373     # hard or borderline impossible for them to occur.
 374     # We also have to think about whether to attempt reconnection
 375     # or not.
 376     switch ($error_code) {
 377         case ($ERROR_NETWORK_ERROR) {
 378             $protocol->network_error($jid);
 379             $error = "Network error, attempting reconnection";
 380             $attempt_reconnect = 1;
 381         }
 382         case ($ERROR_INVALID_USERNAME) {
 383             $protocol->invalid_username($jid);
 384             $error = "Remote server reports invalid username; please reregister";
 385         }
 386         case ($ERROR_AUTHENTICATION_FAILED) {
 387             $protocol->wrong_authentication($jid);
 388             $error = "Username or password invalid; please register with correct information";
 389         }
 390         case ($ERROR_AUTHENTICATION_IMPOSSIBLE) {
 391             $protocol->_handle_error
 392                 ($jid, 'Thrasher Bird can not negotiate an '
 393                  .'authentication technique with the remote '
 394                  .'service', 'service_unavailable');
 395             # This is a bad one, we don't know what to do.
 396             $error = "Authentication impossible";
 397         }
 398         case ($ERROR_NO_SSL_SUPPORT) {
 399             $protocol->_handle_error
 400                 ($jid, 'libpurple was compiled without SSL '
 401                  .'support, but SSL is required by the '
 402                  .'remote service.', 'service_unavailable');
 403             $error = "Thrasher Bird is unable to connect";
 404         }
 405         case ($ERROR_ENCRYPTION_ERROR) {
 406             $protocol->_handle_error
 407                 ($jid, 'There was an error negotiating SSL with '
 408                  .'the remote service, or the remote service '
 409                  .'does not support encryption but an account '
 410                  .'option was set to require it.',
 411                  'service_unavailable');
 412             $error = "Thrasher Bird is unable to connect";
 413         }
 414         case ($ERROR_NAME_IN_USE) {
 415             $protocol->name_in_use($jid);
 416             $error = "The remote service reports your username is in use";
 417         }
 418         case ($ERROR_INVALID_SETTINGS) {
 419             $protocol->invalid_username($jid);
 420             $error = "Remote server reports invalid username; please reregister";
 421         }
 422         case ($ERROR_OTHER_ERROR) {
 423             my $error_message = "Unknown connection error.";
 424             if ($message) {
 425                 $error_message .= ' The legacy service reported: '
 426                     . $message;
 427             }
 428             $protocol->_handle_error
 429                 ($jid, $error_message, 'internal_server_error');
 430         }
 431         else {
 432             log("Got connection error: $error_code for $jid");
 433         }
 434     }
 435
 436     # This needs to be kept in sync with libpurple's
 437     # connection.c -> purple_connection_is_fatal, which
 438     # tracks whether libpurple is going to automatically
 439     # log out our connection in purple_connection_error_reason.
 440     my $purple_will_kill = !($error_code == $ERROR_NETWORK_ERROR ||
 441                              $error_code == $ERROR_ENCRYPTION_ERROR);
 442     $session->{purple_will_kill} = $purple_will_kill;
 443     $session->{purple_will_kill} ||= $protocol->purple_forces_kill;
 444
 445     $protocol->{component}->logout($session, undef,
 446                                    $error);
 447
 448     # Probe the user's presence to trigger a re-connect attempt
 449     # if they are still online. They may have gone offline in the
 450     # meantime, in which case we don't want to reconnect.
 451     if ($attempt_reconnect) {
 452         my $full_jid = $session->{full_jid};
 453         my $callback = sub {
 454             $protocol->{component}->send_presence_xml($full_jid,
 455                                    'probe');
 456             return 0;
 457         };
 458
 459         log("Going to attempt reconnect in 15 seconds for $session->{full_jid}");
 460
 461         _timeout_add(15000, $callback, undef, "Reconnect $session->{full_jid}");
 462     }
 463
 464     my $continuation = delete($session->{'connection_cb'});
 465     if ($continuation) {
 466         $continuation->(undef);
 467     }
 468     else {
 469         log("_connection_error($jid): No connection_cb?!!");
 470     }
 471
 472     # If you want C-end handling, we need to throw some returns above
 473     return 1;
 474 }
 475
 476 # Callback for incoming messages
 477 sub _incoming_msg {
 478     my ($jid, $sender, $alias, $message, $flags) = @_;
 479
 480     $jid = Encode::decode("UTF-8", $jid);
 481     $sender = Encode::decode("UTF-8", $sender);
 482     $message = Encode::decode("UTF-8", $message);
 483
 484     debug("_incoming_msg from $sender for $jid\n");
 485
 486     my $session = $global_component->session_for($jid);
 487     my $protocol = $session->{protocol};
 488
 489     my $clean_sender = $session->{protocol}->process_remote_username($sender);
 490
 491     $message =~ s/([\x80-\xff])/'&#' . ord($1) . ';'/ge;
 492
 493     if ($flags & $THPPW::PURPLE_MESSAGE_AUTO_RESP) {
 494         $message = '(auto-reply) ' . $message;
 495     }
 496
 497     # Type is currently hard coded...
 498     $protocol->sending_message($clean_sender, $session->{legacy_login},
 499                                $message, 1);
 500
 501     debug("_incoming_msg done\n");
 502
 503     # Thrasher::Protocol::sending_message currently has no returned value
 504     return 1;
 505 }
 506
 507 sub registration {
 508     my $self = shift;
 509     my $jid = shift;
 510     my $registration_info = shift;
 511
 512     debug("###registration($jid) called");
 513
 514     # As a special case, if the registration info's username is
 515     # "fail", we return an error given by $registration_info->{password}.
 516     if ($registration_info->{username} eq 'fail') {
 517         return 0, $registration_info->{password};
 518     } else {
 519         return $self->SUPER::registration($jid, $registration_info);
 520     }
 521 }
 522
 523 # This really should be overridden
 524 sub name { 'Purple' }
 525
 526 sub identifier { 'aim' }
 527
 528 # This method identifies which protocol we're using in Pidgin.
 529 sub prpl {
 530     my $self = shift;
 531
 532     die "prpl not set up for " . ref($self);
 533 }
 534
 535 sub create_login_session {
 536     my $self = shift;
 537     my $continuation = shift;
 538     my $registration_info = shift;
 539     my $full_jid = shift;
 540     my $component = shift;
 541     my $jid = strip_resource($full_jid);
 542
 543     debug("###create_login_session($full_jid)");
 544
 545     # FIXME: Check for existing logins.
 546     my $session = new Thrasher::Session($full_jid,
 547                                         $component,
 548                                         $self,
 549                                         $registration_info->{username});
 550     $global_component = $component;
 551     $self->set_session_state($session, 'logging in');
 552     $component->set_session_for($jid, $session);
 553
 554     for my $key (keys %$registration_info) {
 555         $registration_info->{$key} =
 556             Encode::encode("UTF-8", $registration_info->{$key});
 557     }
 558
 559     if (!$self->valid_id($registration_info->{username}) ||
 560         !$self->valid_password($registration_info->{password})) {
 561         $self->wrong_authentication($full_jid);
 562         $continuation->('not_acceptable');
 563         $component->logout($session);
 564         return;
 565     }
 566
 567     my $jid_enc = Encode::encode('UTF-8', $jid);
 568     my %login_args = (
 569         jid => $jid_enc,
 570         proto => $self->prpl,
 571         %$registration_info,
 572         %{ $self->{'configuration'}->{'extra_login_args'} || {} },
 573     );
 574     my $login_error = THPPW::thrasher_action_login(\%login_args);
 575     my $last_connection_started_at = $self->{'connection_started_at'}->{$jid};
 576
 577     # PurpleAccount already exists. But if component called here,
 578     # the session must already be gone. Thus, must have logged out
 579     # during the async libpurple connection attempt and now trying
 580     # to re-log in.
 581     if ($login_error == 2
 582           && $last_connection_started_at
 583           && time() - $last_connection_started_at > 600) {
 584         # Async libpurple login started more than 10 minutes ago but
 585         # _connection{,_error} has still not come back. Destroy the
 586         # old login attempt and start a new one.
 587         #
 588         # E.g. the PURPLE_CONNECTED state was never reached due to a
 589         # MSN ADL/FQY counting bug?
 590         debug('Discarding aged PurpleAccount attempt from '
 591                 . $last_connection_started_at);
 592         THPPW::thrasher_action_logout($jid_enc);
 593         $login_error = THPPW::thrasher_action_login(\%login_args);
 594         # In theory, logout removed the PurpleAccount so the new
 595         # $login_error can't be 2. But--don't risk it!
 596     }
 597     if ($login_error == 2) {
 598         # Reject for now. Eventually _connection or _connection_error
 599         # will come back and login attempts will be possible again.
 600         #
 601         # Must not be confused with the bad credentials case lest
 602         # Component put the failure in authentication_errors and lock
 603         # logins until the registration changes.
 604         #
 605         # Could have this session "take over" the PurpleAccount, but
 606         # what if credentials differ? Or if libpurple never finishes?
 607         $continuation->('conflict');
 608         $component->logout($session);
 609         return;
 610     }
 611
 612     elsif ($login_error != 0) {
 613         # Rejected before we're even trying to connect pretty
 614         # much means syntactically invalid credentials
 615         $continuation->('not_acceptable');
 616         $component->logout($session);
 617         return;
 618     }
 619
 620     $self->{'connection_started_at'}->{$jid} = time();
 621     $session->{'connection_cb'} = $continuation;
 622 }
 623
 624 sub initial_login {
 625     my $self = shift;
 626     my $session = shift;
 627
 628     debug("###initial_login called");
 629
 630     $session->{logged_in} = 1;
 631 }
 632
 633 sub remove {
 634     my $self = shift;
 635     my $jid = shift;
 636
 637     # FIXME: Can occur if the first action after aim.transport comes
 638     # online is to unregister.
 639     if ($global_component) {
 640         my $session = $global_component->session_for($jid);
 641         if ($session) {
 642             $self->{component}->logout($session);
 643         }
 644     }
 645     else {
 646         log("What? No \$global_component in remove?!?");
 647     }
 648
 649     # A user who attempted to unregister while the transport was
 650     # offline won't log in when it comes back up (and thus doesn't
 651     # need to log out) but might still be registered with the backend.
 652     $self->{backend}->remove($jid);
 653 }
 654
 655 sub subscribe {
 656     my $self = shift;
 657     my $session = shift;
 658     my $target_name = shift;
 659     my $continuation = shift;
 660
 661     debug("###subscribe($session->{jid}, $target_name) called");
 662
 663     $session->{subscribed}->{$target_name} = 1;
 664
 665     THPPW::thrasher_action_buddy_add(Encode::encode("UTF-8",
 666                                                     $session->{jid}),
 667                                      Encode::encode("UTF-8", $target_name));
 668
 669     $continuation->(1);
 670 }
 671
 672 sub unsubscribe {
 673     my $self = shift;
 674     my $session = shift;
 675     my $target_name = shift;
 676     my $continuation = shift;
 677
 678     debug("###unsubscribe($session->{jid}, $target_name) called");
 679
 680     if (!(delete $session->{subscribed}->{$target_name})) {
 681         print STDERR "Warning, removing nonexistant contact\n";
 682     }
 683
 684     THPPW::thrasher_action_buddy_remove(Encode::encode("UTF-8",
 685                                                        $session->{jid}),
 686                                         Encode::encode("UTF-8", $target_name));
 687
 688     $continuation->();
 689 }
 690
 691 sub logout {
 692     my $self = shift;
 693     my ($session, $continuation) = @_;
 694
 695     debug("###logout($session->{jid}) called");
 696
 697     if ($session->{purple_connection_created}
 698         && !$session->{purple_will_kill}) {
 699         THPPW::thrasher_action_logout(Encode::encode("UTF-8", $session->{jid}));
 700     }
 701     elsif (! $session->{purple_connection_created}) {
 702         debug('No purple connection created to log out.');
 703     }
 704
 705     $continuation->($session);
 706     return $self->SUPER::logout(@_);
 707 }
 708
 709 sub debug_logged_in {
 710     my $component = $global_component;
 711     if (! $component) {
 712         debug("No component?!!\n");
 713         return;
 714     }
 715
 716     my $protocol = $component->{'protocol'};
 717     if (! $protocol) {
 718         debug("No protocol?!!\n");
 719         return;
 720     }
 721
 722     print STDERR 'prpl = ' . $protocol->prpl() . "\n";
 723
 724     if ($protocol->{'username_to_session'}) {
 725         print STDERR "protocol->username_to_session:\n";
 726         while (my ($legacy_name, $session)
 727                  = each(%{$protocol->{'username_to_session'}})) {
 728             print STDERR "\t$legacy_name => $session\n";
 729         }
 730     }
 731     else {
 732         debug("No username_to_session?!!\n");
 733     }
 734
 735     if ($component->{'sessions'}) {
 736         print STDERR "component->sessions:\n";
 737         while (my ($jid, $session) = each(%{$component->{'sessions'}})) {
 738             print STDERR "\t$jid => $session\n";
 739         }
 740     }
 741     else {
 742         debug("No component sessions?!!\n");
 743     }
 744
 745     THPPW::thrasher_action_debug_logged_in();
 746 }
 747
 748 sub send_message {
 749     my $self = shift;
 750     my @orig_args = @_;
 751     my ($session, $to, $body_text, $type, $error_sub) = @_;
 752
 753     debug("###send_message called");
 754     if ($session->{'protocol_state'} eq 'logging in') {
 755         debug("###send_message deferred; $session->{jid} still logging in.\n");
 756         $session->on_connection_complete(sub {
 757                                              $self->send_message(@orig_args);
 758                                          });
 759         return;
 760     }
 761
 762     $body_text = $self->process_message($body_text);
 763
 764     debug("###Message From: ".$session->{jid}.", To: $to, body: $body_text\n");
 765
 766     my $result = THPPW::thrasher_action_outgoing_msg
 767         (Encode::encode("UTF-8", $session->{jid}),
 768          Encode::encode("UTF-8", $to),
 769          Encode::encode("UTF-8", $body_text));
 770     debug("Message send result: $result\n");
 771 }
 772
 773 sub outgoing_chatstate {
 774     my ($self, $session, $to, $chatstate) = @_;
 775     debug("###outgoing_chatstate($session->{jid}, $to, $chatstate)\n");
 776
 777     our $chatstate_to_purple ||= {
 778         'composing' => $THPPW::PURPLE_TYPING,
 779         'paused' => $THPPW::PURPLE_TYPED,
 780         'inactive' => $THPPW::PURPLE_NOT_TYPING,
 781         'active' => $THPPW::PURPLE_NOT_TYPING,
 782     };
 783     my $purple_typing_state = $chatstate_to_purple->{$chatstate};
 784     if (! defined($purple_typing_state)) {
 785         debug("Untranslated chatstate: '$chatstate'\n");
 786         return;
 787     }
 788
 789     THPPW::thrasher_action_outgoing_chatstate($session->{'jid'},
 790                                               $to,
 791                                               $purple_typing_state);
 792     return;
 793 }
 794
 795 sub subscribed {
 796     my $self = shift;
 797     my $session = shift;
 798     my $component = shift;
 799     my $legacy_username = shift;
 800
 801     debug("###subscribed called: $legacy_username permitted for $session->{jid}");
 802
 803     THPPW::thrasher_action_buddy_authorize
 804         (Encode::encode("UTF-8", $session->{jid}),
 805          Encode::encode("UTF-8", $legacy_username));
 806
 807     $self->SUPER::subscribed($session, $component, $legacy_username);
 808 }
 809
 810 sub unsubscribed {
 811     my $self = shift;
 812     my $session = shift;
 813     my $component = shift;
 814     my $legacy_username = shift;
 815
 816     debug("###unsubscribed($session->{jid}, $legacy_username) called");
 817
 818     if (!defined($legacy_username)) {
 819         confess "Unsubscribing an undef user; shouldn't be called.";
 820     }
 821
 822     THPPW::thrasher_action_buddy_deauthorize
 823         (Encode::encode("UTF-8", $session->{jid}),
 824          Encode::encode("UTF-8", $legacy_username));
 825 }
 826
 827 sub ft_local_ready {
 828     my ($self, $id) = @_;
 829
 830     THPPW::thrasher_action_ft_ui_ready($id);
 831     return 1;                   # repeat this notification.
 832 }
 833
 834 sub gateway_prompt {
 835     my $self = shift;
 836     my $lang = shift;
 837
 838     return "Gateway prompt";
 839 }
 840
 841 sub gateway_desc {
 842     my $self = shift;
 843
 844     return $self->{gateway_desc};
 845 }
 846
 847 sub user_presence_update {
 848     my $self = shift;
 849     my $session = shift;
 850     my $type = shift || '';
 851     my $show = shift || '';
 852     my $status = shift || '';
 853
 854     debug("user_presence_update called\n");
 855
 856     my $purple_status;
 857
 858     # State table for type/show to purple_status
 859     if ($show eq 'away') {
 860         if ($type eq '') {
 861             if ($status) {
 862                 # 'xaway'
 863                 $purple_status = $purple_presence{'xaway'};
 864             }
 865             else {
 866                 # 'away'
 867                 $purple_status = $purple_presence{'away'};
 868             }
 869         }
 870         else {
 871             logger("Unknown type/show of [$type/$show]");
 872         }
 873     }
 874     elsif ($show eq 'chat' || $show eq '') {
 875         if ($type eq '') {
 876             # 'available'
 877             # This seems like it might have more states
 878             $purple_status = $purple_presence{'available'};
 879         }
 880         elsif ($type eq 'unavailable') {
 881             # 'offline'
 882             $purple_status = $purple_presence{'offline'};
 883         }
 884         else {
 885             logger("Unknown type/show of [$type/$show]");
 886         }
 887     }
 888     elsif ($show eq 'xa' || $show eq 'xaway') {
 889         $purple_status = $purple_presence{'xaway'};
 890     }
 891     else {
 892         logger("Unknown type/show of [$type/$show] (show is completely unrecognized)");
 893     }
 894
 895     if (defined($purple_status)) {
 896         THPPW::thrasher_action_presence(
 897             Encode::encode("UTF-8", $session->{jid}),
 898             $purple_status,     # integer does not need encoding
 899             Encode::encode("UTF-8", $status),
 900         );
 901     }
 902
 903     #debug("User presence update: type: $type, show: $show, purple: $purple_status, status: $status");
 904 }
 905
 906 # Don't do anything with this right now.
 907 sub user_targeted_presence_update {
 908     return;
 909     my $self = shift;
 910     my $session = shift;
 911     my $type = shift || '';
 912     my $show = shift || '';
 913     my $status = shift || '';
 914     my $target_user = shift || '';
 915
 916     #log("User presence update to $target_user: type: $type, show: $show, status: $status");
 917 }
 918
 919 # Subrefs for which to satiate the libpurple monster
 920 sub _timeout_add {
 921     my $interval = shift;
 922     my $code     = shift;
 923     my $trigger  = shift;
 924
 925     debug("perl::timeout_add called\n", 3);
 926
 927     debug("\tinterval = $interval\n", 3) if $interval;
 928     debug("\tcode     = $code\n", 3)     if $code;
 929     debug("\ttrigger  = $trigger\n", 3)  if $trigger;
 930
 931     my $ret = Glib::Timeout->add($interval,
 932                                  ($code, $trigger),
 933                                  G_PRIORITY_DEFAULT);
 934
 935     debug("Glib::Timeout->add returned [$ret]\n", 3);
 936     return $ret;
 937 };
 938
 939
 940 sub _source_remove {
 941     debug("perl::timeout_remove called with $_[0]\n", 3);
 942
 943     return Glib::Source->remove($_[0]);
 944 }
 945
 946
 947 sub _input_add {
 948     my $fd       = shift;
 949     my $cond     = shift;
 950     my $code     = shift;
 951     my $trigger  = shift;
 952
 953     debug("_input_add\n", 3);
 954
 955     my $i = 0;
 956     foreach (@_) {
 957         debug("\t$i = $_\n");
 958         $i++;
 959     }
 960
 961
 962     debug("\tfd       = $fd\n", 3)      if $fd;
 963     debug("\tcond     = $cond\n", 3)    if $cond;
 964     debug("\tcode     = $code\n", 3)    if $code;
 965     debug("\ttrigger  = $trigger\n", 3) if $trigger;
 966
 967     $cond = ($cond == 1) ? 'G_IO_IN' : 'G_IO_OUT';
 968
 969     $cond = [$cond, 'G_IO_ERR', 'G_IO_HUP', 'G_IO_NVAL'];
 970
 971     my $ret = Glib::IO->add_watch($fd,
 972                                   $cond,
 973                                   $code,
 974                                   $trigger,
 975                                   G_PRIORITY_DEFAULT);
 976
 977     debug("Glib::IO->add_watch returned [$ret]\n", 3);
 978
 979     debug("_input_add done\n", 3);
 980
 981     return $ret;
 982 }
 983
 984 # Returns if the given ID is a valid id for the service. This avoids
 985 # some problems that services have when you jam illegal logins in.
 986 # For instance, log in to Yahoo with a Japanese username, and it
 987 # just hangs on the connection, rather than doing anything.
 988 # Note that this is more about not sending in logins that confuse
 989 # the remote services so badly we get no errors, NOT about precisely
 990 # labelling which fields are possible. If the remote service correctly
 991 # determines the password is invalid, then everything's fine.
 992 sub valid_id {
 993     my ($self, $username) = @_;
 994
 995     if ($username =~ m{/}) {
 996         return 0;
 997     }
 998
 999     return 1;
1000 }
1001
1002 sub valid_password {
1003     my ($self, $password) = @_;
1004
1005     # If the prpl requires a password, _purple_connection_new() will
1006     # fail when password is NULL or zero-length without returning an
1007     # error thrasher_login() can detect. Worse, the check in
1008     # purple_account_connect() is slightly different so it wouldn't
1009     # even be detectable through purple_account_request_password() and
1010     # request_fields().
1011     #
1012     # Registering with an empty password therefore begins an
1013     # apparently successful async login that never completes or
1014     # errors. The user also can't re-register or log out because
1015     # they're already "logging in". :(
1016     #
1017     # If the prpl has OPT_PROTO_PASSWORD_OPTIONAL or OPT_PROTO_NO_PASSWORD
1018     # the corresponding subclass should override this.
1019     return !!$password;
1020 }
1021
1022 sub purple_forces_kill { return 0; }
1023
1024 1;