Net::REPL::Client: Allow read/print portions to be overridden separately.

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

package Thrasher::Backend;
use strict;
use warnings;

use Thrasher::Nodeprep qw(:all);
use Thrasher::Roster qw(:constants);
use Thrasher::Log qw(log);

use Carp qw(confess longmess);

=head1 NAME

Thrasher::Backend - base class for storage backends

=head1 DESCRIPTION

Thrasher::Backed abstracts out the backend of the
transport. Transports need to retain a small amount of state 
per user, but this state could be stored in a wide variety of
ways. Thrasher Bird provides some default implementations, 
including ways reverse-compatible with other transports, and
by implementing a new subclass of Thrasher::Backend, you can
provide your own.

Backends are responsible for storing the following information:

=over 4

=item * 

The registration information, which is at a minimum a
legacy ID of some kind and the password information for that ID.

=item * 

The mapping of IDs on the legacy service to JIDs, which
must be readable from both directions (JID -> legacy and 
legacy -> JID). This must, in both directions, be accessed via
utf-8 encoded strings and no other encoding.

=item * 

The storage of a small, arbitrary hash of strings to 
strings, which will likely be empty. 

The backend may encode this in any way it chooses. Optionally, it may
limit (such as hard-coding certain keys and forbidding all else),
or even fail to provide this service, at the cost of not working
with protocols that require it. (Not all protocols do.)

This feature may be removed if we end up not needing it for any
protocol.

=item * 

The list of legacy users on the user's roster. 

This is needed to compare the roster we get when we log on 
to the list of users we remember from last time. Users with a
changed status will have those changes propogated to the user
when they next connect.

=back

Each of things should be accessible by using the JID of the user 
that is using the transport.

A normal backend will implement the following:

=over 4

=item * 

C<new>: To set up any necessary database connections or
what ever.

=item * 

C<registered>

=item * 

C<register>

=item * 

C<remove>

=item * 

C<jid_to_legacy_name>

=item * 

C<retrieve_legacy_name_to_jid>

=item * 

C<store_username_mapping>

=item * 

C<get_roster>

=item * 

C<set_roster>

=item * 

C<set_roster_user_state>

=item *

C<get_roster_user_state>

=item *

C<all_jids> (only needed to be a source for migration)

=back

=head1 INTERFACE

The Thrasher::Backend interface is as follows:

=over 4

=item *

C<new>($configuration_hash) - The configuration hash for the backend,
as provided by the user in the configuration file.

=cut

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

=pod

=item *

C<registered>($jid) - If the user is registered, should return
a hashref containing the users username, password, and any other
relevant fields for the protocol. (Note not all protocols are limited
to those two fields.) If they are not registered, should return
C<undef>.

=cut

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

=pod

=item *

C<register>($jid, $hashref) - The hash ref gives all relevant
registration information for this protocol. Again, it may be more
than just "username" and "password". 

=cut

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

=pod

=item *

C<remove>($jid) - The user identified by the given JID is
being removed from the transport. The JID will not have a resource
on it. The user's data should be removed as well.

=cut

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

=pod

=item *

C<legacy_name_to_jid>($user_jid, $legacy_username, $component_name, $lang):
Returns the JID associated with the $legacy_username, encoded in
UTF-8, for the user identified by C<$jid>, according to the following
rules:

=over 4

=item * 

Once a JID has been returned for a given $legacy_username
to a given user, the same JID must always be returned to that user,
subject to the following exception: If the userr removes themself 
from the transport, the JID may be different if they re-register
at a later time, but must then be the same until the next removal.

=item * 

The JID returned for a given $legacy_username must be unique. 
If your normalization rules map two distinct legacy IDs to the same
JID, they I<must> be disambiguated somehow. 

=item * 

The JID returned absolutely I<must> conform to the nodeprep
and stringprep rules for JIDs and hosts, as described in the RFC.
See Thrasher::Nodeprep for functions to help with this.

=back

This is a template method that calls out to the following routines
to do its work:

=over 4

=item *

C<store_username_mapping>

=item *

C<jid_to_legacy_name> (used by C<unduplicate>)

=item *

C<normalize_name>

=item *

C<unduplicate> (has a useful default implementation)

=back

You probably don't have to modify this method, just implement the
above as desired.

$component_name is assumed to already conform with the JID rules for
a server name, or Thrasher will die long before it gets here.

$lang is currently unused, but gives implementers the possibility to 
meaningfully override the unification process for different languages.
(However, that should probably be done by modifying the code
in this file, not in your override.)

=cut

sub legacy_name_to_jid {
    my $self = shift;
    my $user_jid = shift;
    my $legacy_username = shift;
    my $component_name = shift;
    my $lang = shift;

    # During testing, this won't be true.
    if ($self->{component} && $self->{component}->{protocol}) {
        $legacy_username = $self->{component}->{protocol}->process_remote_username($legacy_username);
    }

    my $current = $self->retrieve_legacy_name_to_jid
        ($user_jid, $legacy_username);
    if (defined($current)) {
        return $current;
    }

    my $default_mapping = $self->normalize_name($legacy_username);
    my $default_jid = $default_mapping . '@' . $component_name;
    
    my $actual_mapping = $self->uniquify_name
        ($user_jid, $default_jid, $lang);

    $self->store_username_mapping($user_jid, $legacy_username, 
                                  $actual_mapping);
    return $actual_mapping;
}

=pod

=item *

C<retrieve_legacy_name_to_jid>($user_jid, $legacy_username):
This directly queries the data store to return what the JID for
the $legacy_username is, or returns undef if there is no
mapping. The component will always use C<legacy_name_to_jid>,
which uses what this function returns if it is defined, or
otherwise takes care of creating and remembering a mapping.

There is no default implementation for this.

=cut

sub retrieve_legacy_name_to_jid {
    my $self = shift;

    die "Method retrieve_legacy_name_to_jid not implemented in "
        .ref($self);
}

=pod

=item *

C<jid_to_legacy_name>($user_jid, $target_jid): Returns the legacy name
associated with the $target_jid, as seen in C<legacy_name_to_jid>, for
transport user C<$user_jid>. 

As much as I'd like to be a tight-ass about jids we've never seen
before, that doesn't seem to be in the cards since so many clients
will just toss out JIDs willy-nilly. If you don't have a remembered
JID, you are required to try to fake one up.

=cut

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

sub fake_up_a_legacy_name {
    my $self = shift;
    my $user_jid = shift;
    my $jid = shift;

    my $legacy_guess = $jid;
    $legacy_guess =~ s/\@.*$//;
    # Extra transforms to match those in nodeprep:
    $legacy_guess =~ s/\%/\@/;

    if ($self->{'component'} && $self->{'component'}->{'protocol'}) {
        $legacy_guess = $self->{'component'}->{'protocol'}->fake_up_a_legacy_name($user_jid, $jid, $legacy_guess);
    }

    # Store it so we don't stomp on it later.
    $self->store_username_mapping($user_jid, $legacy_guess, $jid);
    return $legacy_guess;
}

=pod

=item *

C<jid_has_legacy_name>($user_jid, $target_jid): Returns true if
the target JID already has a legacy name, false otherwise.
Used for uniquing.

=cut

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

=pod 

=item *

C<normalize_name>($legacy_name): This provides
an implemention of a default normalization scheme, using
Thrasher::Nodeprep.

You likely don't need to override this.

=cut

# FIXME: Does this belong with the Protocol, or even in a separate
# library entirely? This belongs with Uniquify, but that may
# not belong here either.
sub normalize_name {
    my $self = shift;
    my $legacy_name = shift;

    if (!defined($legacy_name)) {
        confess "Being asked to normalize 'undef'.";
    }

    # If the stringprep routine results in an empty string,
    # at least return something usable as a JID. This should
    # really never ever happen.
    my $normalized = nodeprep($legacy_name) || 'unknown';
    return $normalized;
}

=pod

=item *

C<store_username_mapping>($user_jid, $legacy_username, $mapped_jid):
The backend has decided on the mapping for the legacy username
for the given user, and the mapping needs to be stored. For the
user identified by $user_jid, store that the $legacy_username maps
to $mapped_jid, such that all future calls to C<legacy_name_to_jid>
will return that mapped jid, and C<jid_to_legacy_name> will return
the $legacy_username.

=cut

sub store_username_mapping {
    my $self = shift;
    die "store_username_mapping unimplemented for " . ref($self);
}

=pod

=item *

C<uniquify_name>($user_jid, $possible_legacy_jid, $lang): Given the
username mappings for $user_jid, return a JID username based
on $possible_legacy_jid that does not return a value when passed
to C<jid_to_legacy_name>, which is to say, it has not been
assigned yet.

This default method ignores language for now, and simply starts 
appending numbers on the end until something unique is found. However,
it should be very, very unusual for unique legacy service names to 
map to the some $possible_legacy_jid; this is I<major> paranoia 
on Thrasher's part.

=cut

sub uniquify_name {
    my $self = shift;
    my $user_jid = shift;
    my $possible_legacy_id = shift;
    my $lang = shift;

    if (!$self->jid_has_legacy_name($user_jid, $possible_legacy_id)) {
        return $possible_legacy_id;
    }

    my ($username, $server) = split /\@/, $possible_legacy_id;

    # More major paranoia; give up after 100, something's wrong;
    # this can happen during debugging
    for (my $i = 2; $i < 100; $i++) {
        my $candidate_jid = $username . $i . '@' . $server;
        if (!$self->jid_has_legacy_name($user_jid, $candidate_jid)) {
            return $candidate_jid;
        }
    }

    die "In uniquify_name, after 98 attempts, couldn't find a "
        ."JID to assign for '$possible_legacy_id'.";
}

=pod

=item *

C<set_avatar>($user_jid, $legacy_username, $avatar_png_data_base64):
The legacy user has set the given avatar for a given legacy_username
for the given $user_jid. vcard and PEPAvatar will use this. This must
fire the "avatar_changed" callback. The avatar should be in PNG
format, and encoded in base64 already.

You need to store this such that C<get_avatar> can retreive the base64
encoding of the avatar.

=cut

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

=pod

=item *
C<get_avatar>($user_jid, $legacy_username): Returns the base64 avatar
information from a corresponding C<set_avatar>.

=cut

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

=pod

=item *

C<all_avatars>($jid): Gets a hash mapping all legacy names
to their avatar value, for migration purposes.

=cut

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

=pod 

=item *

C<get_roster>($user_jid): Returns the roster for the given
user, as a hash where the legacy name is the key and the
type of roster entry is the value, where the value is chosed from
$self->subscribed or $self->want_subscribe. (These are numeric
constants given methods for convenience.) Rosters should not
contain $self->unsubscribed, as that is the assumed default state.

If there is no roster, this function should return an empty hash, not
undef.

Note that for the following few functions, the "roster" only
pertains to what is stored in the Backend. "Clearing the roster",
for instance, does nothing to the user's roster.

This has no default implementation.

=cut

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

=pod

=item *

C<set_roster>($user_jid, $roster): Sets the roster to the given
roster hash, with the C<$roster> hash in the format as described 
in C<get_roster>. This should empty out any current settings and
result in the backend I<only> having the roster as described in 
C<$roster>.

This has no default implementation.

=cut

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

=pod

=item *

C<set_roster_user_state>($user_jid, $legacy_username, $state):
Sets the roster to contain the given C<$legacy_username> in the
given C<$state>, where C<$state> is one of C<$self->subscribed>,
C<$self->unsubscribed>, or C<$self->want_subscribe>. 

In the case that a state is set to C<$self->unsubscribed>, it
should actually be entirely removed from the roster, and not
reported as part of the roster.

This has no default implementation.

=cut

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

=pod

=item *

C<get_roster_user_state>($user_jid, $legacy_username):
Gets the roster state, which is one of constants defined in
Thrasher::Roster. The implementation should always return one
of those three constants, ||= $self->unsubscribed if necessary.

This is used upon initial registration; the legacy service sends the
presence of the remote users immediately, but we can not correctly
propagate that until they have been subscribed to.

=cut

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

=pod

=item *

C<all_jids>(): Returns an arrayref of all JIDs currently in
the system. Used for the migrator.

=cut

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

=pod

=item *

C<all_mappings>($user_jid): Returns a hash ref of all
currently-existing mappings, for migration purposes. The
keys are the legacy names and the values are the JIDs.

=cut

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

=pod

=item *

C<all_misc>($user_jid): Returns a hash ref of all
"misc" values, for migration purposes.

=cut

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

=pod

=item *

C<set_misc>($user_jid, $key, $value): Sets a 'misc'
key/value. If your backend doesn't support this, don't
implement it, as scripts may look at the standard die
message to determine this fact.

=cut

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

=pod

=item *

C<get_misc>($user_jid, $key): Gets a 'misc' value.

=cut

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

=pod

=item *

C<register_protocol>($protocol): Registers the protocol
being used with this backend, which permits backends to
react to protocols as needed. Particularly useful may be
$protocol->registration_items. The default implementation
does nothing.

=cut

sub register_protocol { }

=pod

=back

=cut

# Undocumented: clear_backend completely destroys all data
# in the current backend. Used for testing purposes, to
# reset the backend to a known state before proceding with
# testing. Generally, this is expected to also destroy all
# state that Thrasher Bird understands. 
sub clear_backend {
    my $self = shift;
    die "clear_backend is not implemented in " . ref($self);
}

1;