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