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