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     my $continuation = delete($session->{'connection_cb'});
 305     if ($continuation) {
 306         $continuation->($session);
 307     }
 308     else {
 309         log("_connection($jid): No connection_cb?!!");
 310         return 0;
 311     }
 312
 313     # But libpurple prpl might not be ready to send IMs queued during
 314     # login. Wait until _initial_roster() for online protocol_state.
 315     Glib::Timeout->add(
 316         # If after no _subscription_add()/_initial_roster() happens
 317         # (perhaps the account has no current legacy roster at all?)
 318         # ensure session is eventually set online anyway.
 319         15000,
 320         sub {
 321             if (! $session->{'initial_roster_timeout_active'}
 322                   && ! $session->{'initial_roster'}
 323                   && $session->{'protocol_state'} eq 'logging in') {
 324                 debug("Never called _initial_roster($session->{jid})?\n");
 325                 $protocol->set_session_state($session, 'online');
 326             }
 327             return 0; # No repeat
 328         },
 329         undef,
 330         G_PRIORITY_DEFAULT
 331     );
 332
 333     return 1;
 334 }
 335
 336 sub _connection_error {
 337     my $jid        = shift;
 338     my $error_code = shift;
 339     my $message    = shift;
 340
 341     $jid = Encode::decode("UTF-8", $jid);
 342     $message = Encode::decode("UTF-8", $message);
 343
 344     debug("_connection_error($jid)\n");
 345
 346     my $session = $global_component->session_for($jid);
 347     if (! $session) {
 348         log("No session?!! Error was $error_code/'$message'.");
 349         return 0;
 350     }
 351     my $protocol = $session->{protocol};
 352
 353     my $attempt_reconnect = 0;
 354     my $error = '';
 355
 356     if ($session->{status} =~ /disconnecting/) {
 357         log("Got error code $error_code, but ignoring it since "
 358             ."we're in the middle of disconnecting.");
 359         return 1;
 360     }
 361
 362     # Some of these cases are poorly tested since it's either
 363     # hard or borderline impossible for them to occur.
 364     # We also have to think about whether to attempt reconnection
 365     # or not.
 366     switch ($error_code) {
 367         case ($ERROR_NETWORK_ERROR) {
 368             $protocol->network_error($jid);
 369             $error = "Network error, attempting reconnection";
 370             $attempt_reconnect = 1;
 371         }
 372         case ($ERROR_INVALID_USERNAME) {
 373             $protocol->invalid_username($jid);
 374             $error = "Remote server reports invalid username; please reregister";
 375         }
 376         case ($ERROR_AUTHENTICATION_FAILED) {
 377             $protocol->wrong_authentication($jid);
 378             $error = "Username or password invalid; please register with correct information";
 379         }
 380         case ($ERROR_AUTHENTICATION_IMPOSSIBLE) {
 381             $protocol->_handle_error
 382                 ($jid, 'Thrasher Bird can not negotiate an '
 383                  .'authentication technique with the remote '
 384                  .'service', 'service_unavailable');
 385             # This is a bad one, we don't know what to do.
 386             $error = "Authentication impossible";
 387         }
 388         case ($ERROR_NO_SSL_SUPPORT) {
 389             $protocol->_handle_error
 390                 ($jid, 'libpurple was compiled without SSL '
 391                  .'support, but SSL is required by the '
 392                  .'remote service.', 'service_unavailable');
 393             $error = "Thrasher Bird is unable to connect";
 394         }
 395         case ($ERROR_ENCRYPTION_ERROR) {
 396             $protocol->_handle_error
 397                 ($jid, 'There was an error negotiating SSL with '
 398                  .'the remote service, or the remote service '
 399                  .'does not support encryption but an account '
 400                  .'option was set to require it.',
 401                  'service_unavailable');
 402             $error = "Thrasher Bird is unable to connect";
 403         }
 404         case ($ERROR_NAME_IN_USE) {
 405             $protocol->name_in_use($jid);
 406             $error = "The remote service reports your username is in use";
 407         }
 408         case ($ERROR_INVALID_SETTINGS) {
 409             $protocol->invalid_username($jid);
 410             $error = "Remote server reports invalid username; please reregister";
 411         }
 412         case ($ERROR_OTHER_ERROR) {
 413             my $error_message = "Unknown connection error.";
 414             if ($message) {
 415                 $error_message .= ' The legacy service reported: '
 416                     . $message;
 417             }
 418             $protocol->_handle_error
 419                 ($jid, $error_message, 'internal_server_error');
 420         }
 421         else {
 422             log("Got connection error: $error_code for $jid");
 423         }
 424     }
 425
 426     # This needs to be kept in sync with libpurple's
 427     # connection.c -> purple_connection_is_fatal, which
 428     # tracks whether libpurple is going to automatically
 429     # log out our connection in purple_connection_error_reason.
 430     my $purple_will_kill = !($error_code == $ERROR_NETWORK_ERROR ||
 431                              $error_code == $ERROR_ENCRYPTION_ERROR);
 432     $session->{purple_will_kill} = $purple_will_kill;
 433     $session->{purple_will_kill} ||= $protocol->purple_forces_kill;
 434
 435     $protocol->{component}->logout($session, undef,
 436                                    $error);
 437
 438     # Probe the user's presence to trigger a re-connect attempt
 439     # if they are still online. They may have gone offline in the
 440     # meantime, in which case we don't want to reconnect.
 441     if ($attempt_reconnect) {
 442         my $full_jid = $session->{full_jid};
 443         my $callback = sub {
 444             $protocol->{component}->send_presence_xml($full_jid,
 445                                    'probe');
 446             return 0;
 447         };
 448
 449         log("Going to attempt reconnect in 15 seconds for $session->{full_jid}");
 450
 451         _timeout_add(15000, $callback, undef, "Reconnect $session->{full_jid}");
 452     }
 453     # If you want C-end handling, we need to throw some returns above
 454     return 1;
 455 }
 456
 457 # Callback for incoming messages
 458 sub _incoming_msg {
 459     my ($jid, $sender, $alias, $message, $flags) = @_;
 460
 461     $jid = Encode::decode("UTF-8", $jid);
 462     $sender = Encode::decode("UTF-8", $sender);
 463     $message = Encode::decode("UTF-8", $message);
 464
 465     debug("_incoming_msg from $sender for $jid\n");
 466
 467     my $session = $global_component->session_for($jid);
 468     my $protocol = $session->{protocol};
 469
 470     my $clean_sender = $session->{protocol}->process_remote_username($sender);
 471
 472     $message =~ s/([\x80-\xff])/'&#' . ord($1) . ';'/ge;
 473
 474     if ($flags & $THPPW::PURPLE_MESSAGE_AUTO_RESP) {
 475         $message = '(auto-reply) ' . $message;
 476     }
 477
 478     # Type is currently hard coded...
 479     $protocol->sending_message($clean_sender, $session->{legacy_login},
 480                                $message, 1);
 481
 482     debug("_incoming_msg done\n");
 483
 484     # Thrasher::Protocol::sending_message currently has no returned value
 485     return 1;
 486 }
 487
 488 sub registration {
 489     my $self = shift;
 490     my $jid = shift;
 491     my $registration_info = shift;
 492
 493     debug("###registration($jid) called");
 494
 495     # As a special case, if the registration info's username is
 496     # "fail", we return an error given by $registration_info->{password}.
 497     if ($registration_info->{username} eq 'fail') {
 498         return 0, $registration_info->{password};
 499     } else {
 500         return $self->SUPER::registration($jid, $registration_info);
 501     }
 502 }
 503
 504 # This really should be overridden
 505 sub name { 'Purple' }
 506
 507 sub identifier { 'aim' }
 508
 509 # This method identifies which protocol we're using in Pidgin.
 510 sub prpl {
 511     my $self = shift;
 512
 513     die "prpl not set up for " . ref($self);
 514 }
 515
 516 sub create_login_session {
 517     my $self = shift;
 518     my $continuation = shift;
 519     my $registration_info = shift;
 520     my $full_jid = shift;
 521     my $component = shift;
 522     my $jid = strip_resource($full_jid);
 523
 524     debug("###create_login_session($full_jid)");
 525
 526     # FIXME: Check for existing logins.
 527     my $session = new Thrasher::Session($full_jid,
 528                                         $component,
 529                                         $self,
 530                                         $registration_info->{username});
 531     $global_component = $component;
 532     $self->set_session_state($session, 'logging in');
 533     $component->set_session_for($jid, $session);
 534
 535     for my $key (keys %$registration_info) {
 536         $registration_info->{$key} =
 537             Encode::encode("UTF-8", $registration_info->{$key});
 538     }
 539
 540     if (!$self->valid_id($registration_info->{username}) ||
 541         !$self->valid_password($registration_info->{password})) {
 542         $self->wrong_authentication($full_jid);
 543         $continuation->('not_acceptable');
 544         $component->logout($session);
 545         return;
 546     }
 547
 548     # 0 => no thrasher_action_login error.
 549     my $login_error = THPPW::thrasher_action_login({
 550         jid => Encode::encode("UTF-8", $jid),
 551         proto => $self->prpl,
 552         %$registration_info,
 553         %{ $self->{'configuration'}->{'extra_login_args'} || {} },
 554     });
 555     if ($login_error == 2) {
 556         # PurpleAccount already exists. But if component called here,
 557         # the session must already be gone. Thus, must have logged out
 558         # during the async libpurple connection attempt and now trying
 559         # to log back in.
 560         #
 561         # Reject for now. Eventually _connection or _connection_error
 562         # will come back and login attempts will be possible again.
 563         #
 564         # Must not be confused with the bad credentials case lest
 565         # Component put the failure in authentication_errors and lock
 566         # logins until the registration changes.
 567         #
 568         # Could have this session "take over" the PurpleAccount, but
 569         # what if credentials differ?
 570         $continuation->('conflict');
 571         $component->logout($session);
 572         return;
 573     }
 574     elsif ($login_error != 0) {
 575         # Rejected before we're even trying to connect pretty
 576         # much means syntactically invalid credentials
 577         $continuation->('not_acceptable');
 578         $component->logout($session);
 579         return;
 580     }
 581
 582     $session->{'connection_cb'} = $continuation;
 583 }
 584
 585 sub initial_login {
 586     my $self = shift;
 587     my $session = shift;
 588
 589     debug("###initial_login called");
 590
 591     $session->{logged_in} = 1;
 592 }
 593
 594 sub remove {
 595     my $self = shift;
 596     my $jid = shift;
 597
 598     # FIXME: Can occur if the first action after aim.transport comes
 599     # online is to unregister.
 600     if ($global_component) {
 601         my $session = $global_component->session_for($jid);
 602         if ($session) {
 603             $self->{component}->logout($session);
 604         }
 605     }
 606     else {
 607         log("What? No \$global_component in remove?!?");
 608     }
 609
 610     # A user who attempted to unregister while the transport was
 611     # offline won't log in when it comes back up (and thus doesn't
 612     # need to log out) but might still be registered with the backend.
 613     $self->{backend}->remove($jid);
 614 }
 615
 616 sub subscribe {
 617     my $self = shift;
 618     my $session = shift;
 619     my $target_name = shift;
 620     my $continuation = shift;
 621
 622     debug("###subscribe($session->{jid}, $target_name) called");
 623
 624     $session->{subscribed}->{$target_name} = 1;
 625
 626     THPPW::thrasher_action_buddy_add(Encode::encode("UTF-8",
 627                                                     $session->{jid}),
 628                                      Encode::encode("UTF-8", $target_name));
 629
 630     $continuation->(1);
 631 }
 632
 633 sub unsubscribe {
 634     my $self = shift;
 635     my $session = shift;
 636     my $target_name = shift;
 637     my $continuation = shift;
 638
 639     debug("###unsubscribe($session->{jid}, $target_name) called");
 640
 641     if (!(delete $session->{subscribed}->{$target_name})) {
 642         print STDERR "Warning, removing nonexistant contact\n";
 643     }
 644
 645     THPPW::thrasher_action_buddy_remove(Encode::encode("UTF-8",
 646                                                        $session->{jid}),
 647                                         Encode::encode("UTF-8", $target_name));
 648
 649     $continuation->();
 650 }
 651
 652 sub logout {
 653     my $self = shift;
 654     my ($session, $continuation) = @_;
 655
 656     debug("###logout($session->{jid}) called");
 657
 658     if ($session->{purple_connection_created}
 659         && !$session->{purple_will_kill}) {
 660         THPPW::thrasher_action_logout(Encode::encode("UTF-8", $session->{jid}));
 661     }
 662     elsif (! $session->{purple_connection_created}) {
 663         debug('No purple connection created to log out.');
 664     }
 665
 666     $continuation->($session);
 667     return $self->SUPER::logout(@_);
 668 }
 669
 670 sub debug_logged_in {
 671     my $component = $global_component;
 672     if (! $component) {
 673         debug("No component?!!\n");
 674         return;
 675     }
 676
 677     my $protocol = $component->{'protocol'};
 678     if (! $protocol) {
 679         debug("No protocol?!!\n");
 680         return;
 681     }
 682
 683     print STDERR 'prpl = ' . $protocol->prpl() . "\n";
 684
 685     if ($protocol->{'username_to_session'}) {
 686         print STDERR "protocol->username_to_session:\n";
 687         while (my ($legacy_name, $session)
 688                  = each(%{$protocol->{'username_to_session'}})) {
 689             print STDERR "\t$legacy_name => $session\n";
 690         }
 691     }
 692     else {
 693         debug("No username_to_session?!!\n");
 694     }
 695
 696     if ($component->{'sessions'}) {
 697         print STDERR "component->sessions:\n";
 698         while (my ($jid, $session) = each(%{$component->{'sessions'}})) {
 699             print STDERR "\t$jid => $session\n";
 700         }
 701     }
 702     else {
 703         debug("No component sessions?!!\n");
 704     }
 705
 706     THPPW::thrasher_action_debug_logged_in();
 707 }
 708
 709 sub send_message {
 710     my $self = shift;
 711     my @orig_args = @_;
 712     my ($session, $to, $body_text, $type, $error_sub) = @_;
 713
 714     debug("###send_message called");
 715     if ($session->{'protocol_state'} eq 'logging in') {
 716         debug("###send_message deferred; $session->{jid} still logging in.\n");
 717         $session->on_connection_complete(sub {
 718                                              $self->send_message(@orig_args);
 719                                          });
 720         return;
 721     }
 722
 723     $body_text = $self->process_message($body_text);
 724
 725     debug("###Message From: ".$session->{jid}.", To: $to, body: $body_text\n");
 726
 727     my $result = THPPW::thrasher_action_outgoing_msg
 728         (Encode::encode("UTF-8", $session->{jid}),
 729          Encode::encode("UTF-8", $to),
 730          Encode::encode("UTF-8", $body_text));
 731     debug("Message send result: $result\n");
 732 }
 733
 734 sub outgoing_chatstate {
 735     my ($self, $session, $to, $chatstate) = @_;
 736     debug("###outgoing_chatstate($session->{jid}, $to, $chatstate)\n");
 737
 738     our $chatstate_to_purple ||= {
 739         'composing' => $THPPW::PURPLE_TYPING,
 740         'paused' => $THPPW::PURPLE_TYPED,
 741         'inactive' => $THPPW::PURPLE_NOT_TYPING,
 742         'active' => $THPPW::PURPLE_NOT_TYPING,
 743     };
 744     my $purple_typing_state = $chatstate_to_purple->{$chatstate};
 745     if (! defined($purple_typing_state)) {
 746         debug("Untranslated chatstate: '$chatstate'\n");
 747         return;
 748     }
 749
 750     THPPW::thrasher_action_outgoing_chatstate($session->{'jid'},
 751                                               $to,
 752                                               $purple_typing_state);
 753     return;
 754 }
 755
 756 sub subscribed {
 757     my $self = shift;
 758     my $session = shift;
 759     my $component = shift;
 760     my $legacy_username = shift;
 761
 762     debug("###subscribed called: $legacy_username permitted for $session->{jid}");
 763
 764     THPPW::thrasher_action_buddy_authorize
 765         (Encode::encode("UTF-8", $session->{jid}),
 766          Encode::encode("UTF-8", $legacy_username));
 767
 768     $self->SUPER::subscribed($session, $component, $legacy_username);
 769 }
 770
 771 sub unsubscribed {
 772     my $self = shift;
 773     my $session = shift;
 774     my $component = shift;
 775     my $legacy_username = shift;
 776
 777     debug("###unsubscribed($session->{jid}, $legacy_username) called");
 778
 779     if (!defined($legacy_username)) {
 780         confess "Unsubscribing an undef user; shouldn't be called.";
 781     }
 782
 783     THPPW::thrasher_action_buddy_deauthorize
 784         (Encode::encode("UTF-8", $session->{jid}),
 785          Encode::encode("UTF-8", $legacy_username));
 786 }
 787
 788 sub ft_local_ready {
 789     my ($self, $id) = @_;
 790
 791     THPPW::thrasher_action_ft_ui_ready($id);
 792     return 1;                   # repeat this notification.
 793 }
 794
 795 sub gateway_prompt {
 796     my $self = shift;
 797     my $lang = shift;
 798
 799     return "Gateway prompt";
 800 }
 801
 802 sub gateway_desc {
 803     my $self = shift;
 804
 805     return $self->{gateway_desc};
 806 }
 807
 808 sub user_presence_update {
 809     my $self = shift;
 810     my $session = shift;
 811     my $type = shift || '';
 812     my $show = shift || '';
 813     my $status = shift || '';
 814
 815     debug("user_presence_update called\n");
 816
 817     my $purple_status;
 818
 819     # State table for type/show to purple_status
 820     if ($show eq 'away') {
 821         if ($type eq '') {
 822             if ($status) {
 823                 # 'xaway'
 824                 $purple_status = $purple_presence{'xaway'};
 825             }
 826             else {
 827                 # 'away'
 828                 $purple_status = $purple_presence{'away'};
 829             }
 830         }
 831         else {
 832             logger("Unknown type/show of [$type/$show]");
 833         }
 834     }
 835     elsif ($show eq 'chat' || $show eq '') {
 836         if ($type eq '') {
 837             # 'available'
 838             # This seems like it might have more states
 839             $purple_status = $purple_presence{'available'};
 840         }
 841         elsif ($type eq 'unavailable') {
 842             # 'offline'
 843             $purple_status = $purple_presence{'offline'};
 844         }
 845         else {
 846             logger("Unknown type/show of [$type/$show]");
 847         }
 848     }
 849     elsif ($show eq 'xa' || $show eq 'xaway') {
 850         $purple_status = $purple_presence{'xaway'};
 851     }
 852     else {
 853         logger("Unknown type/show of [$type/$show] (show is completely unrecognized)");
 854     }
 855
 856     if (defined($purple_status)) {
 857         THPPW::thrasher_action_presence(
 858             Encode::encode("UTF-8", $session->{jid}),
 859             $purple_status,     # integer does not need encoding
 860             Encode::encode("UTF-8", $status),
 861         );
 862     }
 863
 864     #debug("User presence update: type: $type, show: $show, purple: $purple_status, status: $status");
 865 }
 866
 867 # Don't do anything with this right now.
 868 sub user_targeted_presence_update {
 869     return;
 870     my $self = shift;
 871     my $session = shift;
 872     my $type = shift || '';
 873     my $show = shift || '';
 874     my $status = shift || '';
 875     my $target_user = shift || '';
 876
 877     #log("User presence update to $target_user: type: $type, show: $show, status: $status");
 878 }
 879
 880 # Subrefs for which to satiate the libpurple monster
 881 sub _timeout_add {
 882     my $interval = shift;
 883     my $code     = shift;
 884     my $trigger  = shift;
 885
 886     debug("perl::timeout_add called\n", 3);
 887
 888     debug("\tinterval = $interval\n", 3) if $interval;
 889     debug("\tcode     = $code\n", 3)     if $code;
 890     debug("\ttrigger  = $trigger\n", 3)  if $trigger;
 891
 892     my $ret = Glib::Timeout->add($interval,
 893                                  ($code, $trigger),
 894                                  G_PRIORITY_DEFAULT);
 895
 896     debug("Glib::Timeout->add returned [$ret]\n", 3);
 897     return $ret;
 898 };
 899
 900
 901 sub _source_remove {
 902     debug("perl::timeout_remove called with $_[0]\n", 3);
 903
 904     return Glib::Source->remove($_[0]);
 905 }
 906
 907
 908 sub _input_add {
 909     my $fd       = shift;
 910     my $cond     = shift;
 911     my $code     = shift;
 912     my $trigger  = shift;
 913
 914     debug("_input_add\n", 3);
 915
 916     my $i = 0;
 917     foreach (@_) {
 918         debug("\t$i = $_\n");
 919         $i++;
 920     }
 921
 922
 923     debug("\tfd       = $fd\n", 3)      if $fd;
 924     debug("\tcond     = $cond\n", 3)    if $cond;
 925     debug("\tcode     = $code\n", 3)    if $code;
 926     debug("\ttrigger  = $trigger\n", 3) if $trigger;
 927
 928     $cond = ($cond == 1) ? 'G_IO_IN' : 'G_IO_OUT';
 929
 930     $cond = [$cond, 'G_IO_ERR', 'G_IO_HUP', 'G_IO_NVAL'];
 931
 932     my $ret = Glib::IO->add_watch($fd,
 933                                   $cond,
 934                                   $code,
 935                                   $trigger,
 936                                   G_PRIORITY_DEFAULT);
 937
 938     debug("Glib::IO->add_watch returned [$ret]\n", 3);
 939
 940     debug("_input_add done\n", 3);
 941
 942     return $ret;
 943 }
 944
 945 # Returns if the given ID is a valid id for the service. This avoids
 946 # some problems that services have when you jam illegal logins in.
 947 # For instance, log in to Yahoo with a Japanese username, and it
 948 # just hangs on the connection, rather than doing anything.
 949 # Note that this is more about not sending in logins that confuse
 950 # the remote services so badly we get no errors, NOT about precisely
 951 # labelling which fields are possible. If the remote service correctly
 952 # determines the password is invalid, then everything's fine.
 953 sub valid_id {
 954     return 1;
 955 }
 956
 957 sub valid_password {
 958     my ($self, $password) = @_;
 959
 960     # If the prpl requires a password, _purple_connection_new() will
 961     # fail when password is NULL or zero-length without returning an
 962     # error thrasher_login() can detect. Worse, the check in
 963     # purple_account_connect() is slightly different so it wouldn't
 964     # even be detectable through purple_account_request_password() and
 965     # request_fields().
 966     #
 967     # Registering with an empty password therefore begins an
 968     # apparently successful async login that never completes or
 969     # errors. The user also can't re-register or log out because
 970     # they're already "logging in". :(
 971     #
 972     # If the prpl has OPT_PROTO_PASSWORD_OPTIONAL or OPT_PROTO_NO_PASSWORD
 973     # the corresponding subclass should override this.
 974     return !!$password;
 975 }
 976
 977 sub purple_forces_kill { return 0; }
 978
 979 1;