Push public IM aliases as XMPP roster names and vCard full names.

[thrasher.git] / perl / lib / Thrasher / Protocol.pm

package Thrasher::Protocol;
use strict;
use warnings;

use Data::Dumper;
use Thrasher::Log qw(:all);
use Thrasher::Constants qw(:all);
use Thrasher::Callbacks qw(:all);
use Thrasher::Roster qw(roster_diff);

=head1 NAME

Thrasher::Protocol - base class/interface for protocol differences.

=head1 DESCRIPTION

Thrasher::Protocol abstracts out the various protocol differences
into a simple interface to implement them. Because there are minor
differences, especially in registration and such, it's slightly
more complicated than 

Note that, theoretically, Thrasher can turn anything that conforms
to the API protocol defined in this module into a transport; it
doesn't actually have to back to libpurple! Twitter transport,
anybody?

If you're adding a libpurple protocol, you probably want to subclass
from Thrasher::Protocol::LibPurple which will do a lot of the
libpurple work for you.

Protocol differences include, but are not limited to:

=over 4

=item *

Name of the protocol.

=item * 

Registration instructions.

=item *

Registration result; this object will recieve notification
when a registration is completed.

=item *

How to actually perform the various work parts of the protocol.

=item *

Methods to reflect actions from the protocol back out to the
component. The Thrasher::Protocol superclass will implement the
communication with the ::Component, and that may be sufficient for
your protocol, but the ::Protocol gets a chance at the call just
in case you need something.

=back

Some of the methods below have a useful default implementation that
will work for the vast majority of implementations, but some don't.
Some methods can be entirely overridden, some must call the superclass.

=head1 METHODS

Only the top-level configuration file will call:

=over 4

=item *

C<new>($configuration, $backend): The configuration argument hash is
what is passed in by component.pl.

The default implementation copies these into keys of $self.

=back

=head2 Component Interface

These are things that the ::Component will call the ::Protocol with.

=over 4

=cut

sub new {
    my $class = shift;
    my $self = {};
    bless $self, $class;

    $self->{configuration} = shift;
    $self->{backend} = shift;

    return $self;
}

=pod

=item *

C<registration_xml>(): Should return the instructions for
registration, in the XML format favored by Thrasher::XMPPStreamOut.
Be sure to put the tags in the correct $NS_REGISTER namespace.

If the user is already registered according to the backend, 
a <registered/> tag should be emitted, in accordance with the
standard section 4.2.1 #2, as well as returning the relevant
values for the registration.

This will automatically be used as the children of a <query> tag,
so you should just return the children (in an array ref).

A default implementation is provided, based on the C<registered> 
method of the backend, as long the protocol only needs a 
standard username and password.

=cut

sub registration_xml { 
    my $self = shift;
    my $jid = shift;
    
    my $registration = $self->{backend}->registered($jid);

    return [[[$NS_REGISTER, 'instructions'], {},
             ['Please provide your username and password for '
              .$self->name]],
            ($registration ? ([[$NS_REGISTER, 'registered'], {}, []])
             : ()),
            [[$NS_REGISTER, 'username'], {},
             [$registration->{username} ? ($registration->{username}) : ()]],
            [[$NS_REGISTER, 'password'], {}, 
             [$registration->{password} ? ($registration->{password}) : ()]]];
}

=pod

=item *

C<registration_items>: Should return a list of elements that are
required to login. This will be verified against the user's
registration at login time to verify that they have all required
elements. 

The default implementation returns qw(username password).

If the user only has some pieces, the user is completely
unregistered.

=cut

# This addresses a bug where users were somehow able to have only a
# password in the DB. I'm not sure how this is possible, but since
# it's a segfault for libpurple for this to happen, it has to be
# stopped, both by fixing the real problem and by making sure that
# even if it happens it still doesn't crash us.

sub registration_items {
    return qw(username password);
}

=pod

=item *

C<registration_defaults>: Should return a hashref of values indicating
the defaults for registration, if given. If the user fails to pass
back a value, but there is a default, the default will be used.

A value must be given for each item or the registration will fail.
username and password should not be given defaults (unless you have
a really good reason of some kind), but since other clients sometimes
choke on anything other than having a username and password, we
need to be able to provide defaults for such clients.

The default implementation returns {}, no surprise.

=cut

# The temptation to write 
# sub registartion defaults { { } }
# was strong...
sub registration_defaults {
    return {};
}

=pod

=item *

C<name>(): Should return the name of the protocol, suitable for
concatenation with the string " Gateway" for describing the gateway.

The default implementation returns $self->{name}, but that won't be 
useful if you don't defined a ->{name}.

=cut

sub name { 
    return $_[0]->{name};
}

=pod 

=item *

C<identifier>(): Should return a lowercase-letter name of the protocol
suitable for use in the domain of the component. i.e., the MSN
transport might return "Microsoft Messenger" for the call to C<name>,
but should return "msn" for this method.

The default implemenation returns $self->{identifier}, but that won't
be useful if you didn't define a ->{identifier}.

=cut

sub identifier {
    return $_[0]->{identifier};
}

=pod

=item *

C<event_loop>(): Should return a Perl module conforming to the
interface set out in Thrasher::EventLoop that can be used to set
up the event loop for Thrasher Bird, including both whatever 
loop is needed for the protocol loop and for talking to the XMPP
server. 

=cut

sub event_loop {
    return 'Thrasher::EventLoop';
}

=pod

=item *

C<gateway_desc>($lang): Should return the thing you want to prompt the
user with, in order to ask them for their user name. See the examples,
or see XEP-0100 section 6.3. This corresponds to the 
<desc> tag, hence the klunky name.

$xml_lang will be the language requested by the user, as seen in their 
xml language attribute in the query. It will already have been
normalized to 'en' if not specified.

The default implementation returns undef, which means "don't give
a description", which the standard permits.

=cut

sub gateway_desc {
    my $self = shift;
    return undef;
}

=pod

=item *

C<gateway_prompt>($lang): Should return the simple name of the
thing you are asking for when adding a contact. See XEP-0100
section 6.3. This corresponds to the <prompt> tag, hence the method
name.

You must implement this.

=cut

sub gateway_prompt {
    my $self = shift;
    die "Method gateway_prompt not implemented in " . ref($self);
}

=pod

=item *

C<registration>($from_jid, $registration_info): $registration_info is
a hash ref containing whatever the user sent back.

This should return a list with the following elements:

=over 4

=item *

A boolean indicating if the registration was successful.

=item *

An identifier which is a key in the C<Thrasher::Component::IQ_ERRORS>
which represents the error to be sent back to the user.

=back

The second is not needed if the registration was successful.

Note that XEP-0100 specifies that the error that should result 
if the user's username and password failed to verify is
'not_acceptable' (note Component.pm uses an underscore).

The default implementation passes this on to the backend's
C<register> method, after processing the registration defaults.

=cut

sub registration {
    my $self = shift;
    my $jid = shift;
    my $registration_info = shift;

    log("Registration defaults: " . Dumper($self->registration_defaults));

    my $registration_defaults = $self->registration_defaults;
    for my $key (keys %$registration_defaults) {
        $registration_info->{$key} ||= $registration_defaults->{$key};
    }

    log("Registering with: " . Dumper($registration_info));

    $self->{backend}->register($jid, $registration_info);
}

=pod 

=item *

C<remove>($from_jid): The given JID (with no resource) is
unregistering from the transport. The protocol likely doesn't care,
but it might. The backend certainly does. The default implementation
passes this along to the backend.

You should probably extend this to disconnect the user from the 
legacy protocol.

=cut

sub remove {
    my $self = shift;
    my $jid = shift;

    $self->{backend}->remove($jid);
}

# FIXME - rewrite this for clarity.

=pod

=item *

C<login>($continuation, $registration_info, $full_jid, $component): This
should generate either a Thrasher::Connection object corresponding to
the given login information (possibly an existing object if we somehow
are logging in without having logged off), OR an string corresponding
to an entry in C<%Thrasher::Component::IQ_ERRORS> indicating
an error.

$full_jid is the JID of the user logging in, with resource.

$registration_info will be a hash corresponding to the one requested
by C<registration_xml>.

$component is a reference to the component generating the login
request. This should be used to reflect the initial presence
state of the legacy subscribed users back out along the connection.

Note the use of "generate" rather than "return"; the generated
Thrasher::Connection or error string should be passed into the
continuation. This is because logging on could be a lengthy 
operation and we of course can't pause for that. Each continuation is
thus a user-specific closure--wires will get crossed if the wrong
continuation is called for an account.

The Thrasher::Protocol object is also expected to remember the connection.

The protocol specifies that you should try to translate the error
you receive into the set of XMPP errors you can send.

This method's default implementation is to forward these parameters
along to the create_login_session, which will either create a 
session and return it, or return a string corresponding to
an error. This method will then store that session with:

  $self->{logged_in}->{$registration_info->{username}} = $session;

which is necessary for routing info later.

Note this is accomplished by adding on to the continuation, so
create_login_session is still documented correctly; it, too, must
call the continuation.

Generally, you won't need to override this method; what you want
to override is C<create_login_session>.

=cut

sub login {
    my $self = shift;
    my $continuation = shift;
    my $registration_info = shift;

    my $new_continuation = sub {
        my ($session_or_error, @args) = @_;

        if (ref($session_or_error)) {
            $self->{username_to_session}->{$registration_info->{username}} =
                $session_or_error;
        }

        $continuation->($session_or_error, @args);
    };

    $self->create_login_session
        ($new_continuation, $registration_info, @_);
}

=pod

=item *

C<logout>($session, $continuation): This should log off the user
from the legacy protocol. $session will be a Thrasher::Session
object, which you should have loaded up with any necessary information
in your login method call. 

Once the logoff has been completed, call the $continuation with 
no arguments.

C<logout> must not fail, and should run $continuation in some reasonable
period of time.

Be sure to consider the state of the current connection.

The default implementation does not run $continuation and is thus
never sufficient. It exists only to manage some internal bookkeeping
for other methods' default implementations.

=cut

sub logout {
    my $self = shift;
    my $session = shift;
    my $continuation = shift;

    # TODO: displaynames are allowed to persist while the protocol object does.

    my $legacy_login = $session->{'legacy_login'};
    delete($self->{'username_to_session'}->{$legacy_login});
}

=pod

=item *

C<subscribe>($session, $legacy_name, $continuation): This should
subscribe the user to the given $legacy_name on the legacy service.
$legacy_name has been converted to be the user name expected by
the legacy service already, you don't need to "unescape" it.

The continuation should be called with either a true value,
indicating the subscription was successful, or a false value,
indicating it failed for any reason. (The standard assumes it
was because the remote user rejected it, so things like "the
user doesn't exist" will be simply failures.)

This has no default implementation.

=cut

sub subscribe {
    my $self = shift;
    my $legacy_name = shift;
    my $continuation = shift;

    die "subscribe method not implemented in " . ref($self);
}

=pod

=item *

C<unsubscribe>($session, $legacy_name, $continuation): This
should unsubscribe the user to the given $legacy_name on the
legacy service. The continuation should be called when
this is complete, with no arguments. (XMPP basically assumes
that unsubscriptions always complete.)

=cut

sub unsubscribe {
    my $self = shift;
    
    die "unsubscribe method not implemented in " . ref($self);
}

=pod

=item *

C<send_message>($session, $to, $body_text, $type, $error_sub):
Send the given message to the given user of the given (XMPP message)
type. That is, the XMPP user has sent a message to
somebody@transport.type, and this method needs to implement the
sending of that message along the transport.

If the message sending fails, call the $error_sub with the appropriate
error name. The standard specifies (converted to Thrasher's
constants):

=over 4

=item *

C<item_not_found>: Legacy User address is not valid.

=item *

C<registration_required>: Jabber User is not registered with Gateway.

C<service_unavailable>: Legacy User is offline and Legacy Service (or
Gateway) does not provide offline message storage. 

C<remote_server_timeout>: Legacy Service cannot be reached.

=back

C<$to> will be the legacy name, not the JID. If you need them, you can
either convert them back out or get the sender JID from the session.

This has no default implementation.

=cut

sub send_message {
    my $self = shift;
    die "send_message method not implemented in " . ref($self);
}

=pod

=item *

C<outgoing_chatstate>($session, $to, $chatstate):
Called when a chatstates stanza is received from the XMPP user
directed at the legacy username C<$to>. C<$to> is as for send_message.

The default implementation is to ignore chatstates.

=cut

sub outgoing_chatstate {
    my ($self, $session, $to, $chatstate) = @_;
    # ignore!
}

=pod

=item *

C<subscribed>($session, $component, $legacy_username): The user has accepted
the subscription request by the given legacy username; handle it
as you should. ::Session actually takes care of the presence tags.

The default implementation will propogate presence information stored
in $session->{presence_waiting_for_subscribe} as appropriate. You will
need to override this method, but the override should call this back.

=cut


sub subscribed {
    my $self = shift;
    my $session = shift;
    my $component = shift;
    my $legacy_username = shift;

    if (my $presence_info = 
            delete $session->{presence_waiting_for_subscribe}->{$legacy_username}) {
        log("Using stored presence information for $legacy_username");
        $component->send_presence($session->{jid}, $legacy_username,
                                  @$presence_info);
        $session->resend_displayname($legacy_username);
    }
}

=pod

=item *

C<unsubscribed>($session, $component, $legacy_username): The user has rejected 
a subscription request or removed a subscription. Handle it as 
you should for your protocol.

This has no default implementation.

=cut

sub unsubscribed {
    my $self = shift;
    die "unsubscribed method not implemented in " . ref($self);
}

=pod

=item *

C<ft_local_ready>($ft_id):
Called when the file transfer proxy to the user is ready for I/O to
the remote protocol.

Must return true of the protocol should continue to receive this
notification when the proxy is ready. If the protocol will somehow
manage this itself, return false.

=over 4

=item *

C<ft_id>: Protocol's file transfer identifier or object.

=back

=cut

sub ft_local_ready {
    my ($self, $id) = @_;
    die 'ft_local_ready method not implemented in ' . ref($self);
}

=pod

=item *

C<get_displayname>($jid, $legacy_username):
Returns the displayname of the legacy user as it should be presented to $jid.

The default implementation should be sufficient.

=cut

sub get_displayname {
    my ($self, $jid, $legacy_username) = @_;

    return $self->{'displayname'}->{$jid}->{$legacy_username};
}

=pod

=back

=head2 Protocol Interface

These are methods that you will call in your protocol handler to 
inform the component about events. Default implementations are 
provided in Thrasher::Protocol, and are likely to be sufficient
for your needs.

Note how all these method names have gerund names.

=over 4

=item *

C<adding_contact>($legacy_username_from, $jid_to): A legacy user
is adding a user on this transport to their roster. The component will
handle the XML going out to the user when you call 
C<$component->add_contact($jid_to, $legacy_username_from)>.

The default implementation of this does that and is probably
sufficient.

=cut

sub adding_contact {
    my $self = shift;
    my $legacy_username_from = shift;
    my $subscription_to = shift;

    my $subscription_from = $self->{backend}->legacy_name_to_jid
        ($subscription_to, $legacy_username_from, 
         $self->{component}->{component_name}, 'en');

    log("Adding contact: $legacy_username_from -> $subscription_to");

    my $session = $self->{component}->session_for($subscription_to);
    if (!defined($session)) {
        log("Getting a contact addition request for a username that "
            ."doesn't seem to be logged in: $legacy_username_from is "
            ."asking to subscribe to $subscription_to with the "
            .$self->name . " protocol.");
        return;
    }

    my $component = $session->{component};
    my $jid_to = $session->{jid};
    # Implements section 5.1.1 #2
    $component->add_contact($jid_to, $legacy_username_from);

    my $state = $self->{backend}->get_roster_user_state($session->{jid},
                                                        $legacy_username_from);
    debug("roster state was $state");
    if ($state != $self->{backend}->subscribed()) {
        $self->{backend}->set_roster_user_state(
            $session->{jid},
            $legacy_username_from,
            $self->{backend}->want_subscribe
        );
    }
}

=pod

=item *

C<deleting_contact>($subscription_from, $subscription_to): A
legacy user is removing the XMPP user from their subscription
list.

The default implementation of this is probably sufficient.

=cut

sub deleting_contact {
    my $self = shift;
    my $subscription_from = shift;
    my $subscription_to = shift;

    log("Deleting contact: $subscription_from -> $subscription_to");

    my $session = $self->{username_to_session}->{$subscription_to};
    if (!defined($session)) {
        log("Getting a contact removal request for a username that "
            ."doesn't seem to be logged in: $subscription_from is "
            ."asking to unsubscribe from $subscription_to with the "
            .$self->name . " protocol.");
        return;
    }

    my $component = $session->{component};
    my $jid_to = $session->{jid};
    $component->delete_contact($jid_to, $subscription_from);

    $self->{backend}->set_roster_user_state
        ($session->{jid}, $subscription_from,
         $self->{backend}->unsubscribed);
}

=pod

=item *

C<sending_message>($legacy_from, $legacy_to, $message, $is_xhtml_ish):
A legacy user has sent a message. $is_xhtml_ish is propagated to the
::Component::send_message method.

The default implementation of this is probably sufficient.

=cut

sub sending_message {
    my $self = shift;
    my $legacy_from = shift;
    my $legacy_to = shift;
    my $message = shift;
    my $is_xhtml_ish = shift;

    my $session = $self->{username_to_session}->{$legacy_to};
    my $component = $session->{component};
    my $jid_to = $session->{jid};

    my $jid_from = $self->{backend}->legacy_name_to_jid
        ($jid_to, $legacy_from, $component->{component_name},
         'en'); # FIXME: Should know lang in component

    $component->send_message($jid_from, $jid_to, $message, {
        is_xhtml_ish => $is_xhtml_ish,
        children => [ [[ $NS_CHATSTATES, 'active' ], {}, []] ],
    });
}

=pod

=item *

C<initial_login>($session): This is a chance to be called to be
notified about the initial successful login for a given session,
an opportunity to do something with the session. 

The default behavior of this function is to set the current
session state to "online".

=cut

sub initial_login { 
    my $self = shift;
    my $session = shift;

    $self->set_session_state($session, 'online');
}

=pod

=item *

C<incoming_chatstate>($session, $sender, $state_tag): Send a message
from the legacy $sender with only the given chatstate $state_tag for
the $session.

=cut

sub incoming_chatstate {
    my ($self, $session, $sender, $state_tag) = @_;

    my $clean_sender = $self->process_remote_username($sender);
    my $component = $session->{'component'};
    my $jid_from = $self->{'backend'}->legacy_name_to_jid(
        $session->{'jid'},
        $clean_sender,
        $component->{'component_name'},
        # FIXME: Should know lang in component
        'en',
    );

    $component->xml_out([
        [$NS_COMPONENT, 'message'], {
            from => $jid_from,
            to => $session->{'full_jid'},
            type => 'chat',
        },
        [ [[ $NS_CHATSTATES, $state_tag ], {}, []] ]
    ]);
}

=pod

=item *

C<set_session_state>($session, $state): The session's state is one
of several strings indicating what the state of the session is.

The first state is 'disconnected'. The user is disconnected, and
quite frankly we shouldn't even have a session unless they're
trying to connect right now.

The second state is 'logging in'; the user has indicated they
wish to log in and they are in the process of doing so. In this
state, everything that would normally go out the connection needs
to be stored away with the connection is being made, and if the
connection fails, actions may need to be taken.

The third state is 'online', which means the user is online and
all actions can be taken immediately.

In particular, calling C<set_session_state($session, 'online')>
will cause all the deferred processing to take place, which is 
the primary purpose of this method. Going from "logging in"
to "login failed" will cause all deferred error processing to
occur, then the state will be switched to "disconnected".

=cut

sub set_session_state {
    my $self = shift;
    my $session = shift;
    my $state = shift;

    my $current_state = $session->{protocol_state};
    $session->{protocol_state} = $state;

    if ($state eq 'online' && $current_state eq 'logging in') {
        succeeded('legacy_login_' . $session->{internal_id});
    }

    if ($state eq 'login failed' && $current_state eq 'logging in') {
        failed('legacy_login_' . $session->{internal_id});
    }
}

=pod 

=item *

C<user_presence_update($session, $type, $show, $status)>: One of our
XMPP users has sent us a presence update, and we need to reflect
that back out to the transport.

For whatever action you need to take, you really ought to use
C<do_when_logged_in>, so you wait until the user is fully
online before trying to send the update.

This is the "general" presence update.

=cut

sub user_presence_update {
    my $self = shift;
    die "user_presence_update not implemented in " . ref($self);
}

=pod

=item *

C<user_targeted_presence_update($session, $type, $show, $status,
$target_user)>: The XMPP user has sent a targetted presence update,
at the $target_user (which will already be converted to the 
legacy user name).

Note that targeted presence updates I<generally> accompany 
general presence updates (as processed in C<user_presence_update>),
so the naive implementation that sets the presence on the legacy
user is probably not desirable; you should do something more
intelligent, though I'm still not sure exactly what.

=cut

sub user_targeted_presence_update {
    my $self = shift;
    die "user_targeted_presence_update not implemented in "
        . ref($self);
}

=pod

=item *

C<legacy_presence_update($session, $legacy_name, $type, $show,
$status)>: A legacy user has sent a presence update of some
kind. Translate it into the $type, $show, and $status of XMPP,
and call this method. Implemented in Thrasher::Protocol and 
probably doesn't need to be overridden.

=cut

sub legacy_presence_update {
    my $self = shift;
    my $session = shift;
    my $legacy_name = shift;
    my $type = shift;
    my $show = shift;
    my $status = shift;

    # If the XMPP user has still not accepted this presence, 
    # store it away in the session
    if ((my $state = $self->{backend}->get_roster_user_state
        ($session->{jid}, $legacy_name)) !=
        $self->{backend}->subscribed) {
        log("Storing presence information for $legacy_name because state is $state");
        $session->{presence_waiting_for_subscribe}->{$legacy_name} =
            [$type, $show, $status];
        return;
    } else {
        log("Not storing presence info for $legacy_name because state is $state");
    }

    $session->{component}->send_presence
        ($session->{jid}, $legacy_name, $type, $show, $status);
}

=pod

=item *

C<disconnecting>($session): Call this when the protocol is
disconnecting from the remote service, regardless of the reason.
Thrasher will work out whether the user asked for it or not, 
and take appropriate action.

=cut

sub disconnecting {
    my $self = shift;
    my $session = shift;

    my $state = $session->{protocol_state};

    # If the user is already at "disconnected", then the user
    # requested this and life is good.
    if ($state eq 'disconnected') {
        return;
    }
    if ($state eq 'logging in') {
        # FIXME: Login evidently failed, shouldn't we find out
        # more explicitly?
    }
    if ($state eq 'online') {
        # Note we can only get here if we successfully logged in,
        # so we shouldn't see the error case of using all
        # connections because the user gave the wrong password.
        log("Connection for " . $session->{full_jid} . 
            "unexpectedly dropped, scheduling re-connection.");

        $session->{component}->login($session->{full_jid});
    }
}

=pod

=back

=head2 Protocol Services

These are methods that multiple protocols will likely need to use,
so we centralize them here. However, you are not required to use them.

=over

=item *

C<set_current_legacy_roster>($session, $current_roster): The backend is 
required to maintain a copy of the legacy roster, as reflected
in the user's XMPP roster. (Which can go out of sync if they fiddle
with it while not connected to the gateway, or if the gateway isn't
connected, but we can't do anything about in a standards-complaint
way, so far as I know.) If you call this with the current roster,
with the roster working as defined in L<Thrasher::Roster> (a hash
with the legacy user names as keys and values corresponding to
their current subscription state), this will compare it to the
roster as stored in the backend, and issue the necesary <presence>
tags to bring the user's XMPP roster up-to-date, and also handle
the logic necessary to initiate some changes that need to
go longer term (if the user is subscribed remotely and unsubscribed
locally, the move to want_subscribe, not subscribed).

=cut

my $subscribed = Thrasher::Roster::subscribed;
my $unsubscribed = Thrasher::Roster::unsubscribed;
my $want_subscribe = Thrasher::Roster::want_subscribe;

# The actions to take for a given presence transition
my %presence_table = 
    (
     "$subscribed,$unsubscribed" => 
        [['unsubscribed', 'unsubscribe'], $unsubscribed],
     # This is a bit crazy, but it's also an unlikely transition
     "$subscribed,$want_subscribe" => 
        [['unsubscribe', 'unsubscribed', 'subscribe'], $want_subscribe],
     "$unsubscribed,$subscribed" => 
        [['subscribe', 'subscribed'], $want_subscribe],
     "$unsubscribed,$want_subscribe" => 
        [['subscribe'], $want_subscribe],
     "$want_subscribe,$subscribed" => 
        [['subscribe', 'subscribed'], $want_subscribe],
     "$want_subscribe,$unsubscribed" => 
        [['unsubscribe', 'unsubscribed'], $unsubscribed]
     );

sub set_current_legacy_roster {
    my $self = shift;
    my $session = shift;
    my $current_legacy_roster = shift;

    my $jid = $session->{jid};

    my $current_roster =
        $self->{backend}->get_roster($jid);

    my $roster_diffs = roster_diff($current_roster,
                                   $current_legacy_roster);

    my $component = $session->{component};

    for my $legacy_username (sort keys %$roster_diffs) {
        my $key = join ",", @{$roster_diffs->{$legacy_username}};

        # FIXME: We need to centralize the process of unsubscribing
        # and make that a callback, so that avatar handling can 
        # catch unsubscriptions and remove dead avatars.

        my ($presence_to_send, $new_state) =
            @{$presence_table{$key}};

        for my $presence (@$presence_to_send) {
            $component->send_presence($jid, $legacy_username,
                                      $presence);
        }

        # Set the actual current value as processed through the
        # logic
        $current_legacy_roster->{$legacy_username} = $new_state;
    }

    $self->{backend}->set_roster($jid, $current_legacy_roster);
}

=pod

=item *

C<set_displayname>($jid, $legacy_username, $displayname_value):
Stores the displayname of the legacy user as it should be presented to $jid.

If this is overridden, get_displayname() should be, too.

=cut

sub set_displayname {
    my ($self, $jid, $legacy_username, $displayname) = @_;

    debug("set_displayname($jid, $legacy_username, $displayname) called\n");

    if (not $displayname) {
        # Forget it!
        delete($self->{'displayname'}->{$jid}->{$legacy_username});
        return $displayname;
    }

    my $displayname_was = $self->get_displayname($jid, $legacy_username);
    if ($displayname_was && $displayname_was eq $displayname) {
        # Don't send update if unchanged.
        return $displayname;
    }

    $self->{'displayname'}->{$jid}->{$legacy_username} = $displayname;

    # Push change into $jid's roster.
    my $component = $self->{'component'};
    my $legacy_jid = $component->legacy_name_to_xmpp($jid, $legacy_username);
    $component->set_roster_name($jid, $legacy_jid, $displayname);

    return $displayname;
}

=pod

=back

=head2 PRE-CANNED ERRORS

Some errors in the protocol that need to be reflected back to the user 
are fairly common across protocols. These methods can be called
to provide certain canned error messages back out to the user.
If you're I<really> lucky, they'll even be localized!

These will also handle logging out the user if appropriate
(specifically, the component showing as "offline") and setting
an appropriate detailed presence for the component.

=over 4

=item *

C<wrong_authentication>($jid): Will send a message back of the form "The
username and password you have tried to use is being reported as
invalid by the remote service."

=cut

# These will eventually be localized as well
sub _handle_error {
    my $self = shift;
    my $jid = shift;
    my $error = shift;
    my $error_type = shift;

    log("Handling error: $error");

    $self->{component}->send_error_message($jid, $error, $error_type);
}

sub wrong_authentication {
    my $self = shift;
    my $jid = shift;

    $self->_handle_error($jid, 'The username and password you have '
                         .'tried to use is being reported as '
                         .'invalid by the remote service.',
                         'forbidden'); 
}

=pod

=item *

C<name_in_use>($jid): "The name you are using with this service is
logged in at another location."

Note that if the protocol in question already automatically sends
out a message like this, you should not send another. (AIM for
instance will automatically send this out.)

=cut

sub name_in_use {
    my $self = shift;
    my $jid = shift;

    $self->_handle_error($jid, 'The name you are using with this '
                         .'service is logged in at another location.',
                         'bad_request');
}

=pod

=item *

C<invalid_username>($jid): "The username you are trying to
use with this service is an invalid username, according to
the service."

Use this when the username is syntactically invalid. Incorrect
authentication credentials for an otherwise syntactically-valid
username is C<wrong_authentication>.

=cut

sub invalid_username {
    my $self = shift;
    my $jid = shift;

    $self->_handle_error
        ($jid, "The username you are trying to use with "
         ."this service is an invalid username, according "
         ."to this service.", 'not_acceptable');
}

=pod

=item *

C<network_error>($jid): "There was a network error while
attempting to connect to the remote service."

=cut

sub network_error {
    my $self = shift;
    my $jid = shift;

    $self->_handle_error($jid, 'There was a network error while '
                         .'attempting to connect to the remote '
                         .'service.', 'service_unavailable');
}

=pod

=item *

C<process_remote_username>($username): This gives the backend an
opportunity to munge the username if needed. This gives you the
opportunity to make a protocol-specific hack for things like
case sensitivity or other protocol-specific things. AIM, for instance,
will very freely send "Prof Gilzot", "profgilzot", and "ProfGilzot",
all within the same session, but in general Thrasher will (properly,
IMHO) consider that three separate names unless you normalize
them with this function.

The default, of course, is to do nothing to the string.

=cut

sub process_remote_username {
    my $self = shift;
    my $username = shift;

    return $username;
}

=pod

=item *

C<fake_up_a_legacy_name>($user_jid, $jid, $legacy_guess): Gives the
protocol a chance to change the backend's $legacy_guess for $jid's
legacy ID. The default is to accept the guess the backend has already
made; a protocol may override this and return a different string to
improve upon that guess.

The default is to do return the backend's guess unmodified.

=cut

sub fake_up_a_legacy_name {
    my ($self, $user_jid, $jid, $legacy_guess) = @_;

    return $legacy_guess;
}

=pod

=back

=cut

1;