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

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

package Thrasher::Session;
use strict;
use warnings;

=head1 NAME

Thrasher::Session - abstracts out a single session to a legacy
service

=head1 DESCRIPTION

Thrasher::Session abstracts out the parts of code that deal with 
a specific session, which is a (jid, service, registration) tuple. 
This session matches the "session" described in section 4.4 of 
XEP-0100.

A Thrasher::Session is created specifically when a connection is
made and only has to do with things that must be done when connected
to a session, such as sending and receiving messages, subscribing
and unsubscribing legacy users, etc. Once the connection to the legacy
service is terminated, the Session is over. (I'm emphasizing this 
because without this information, you might expect Thrasher::Session
to do more than it does.)

Thrasher::Protocols are responsible for creating Thrasher::Session
objects and returning them back to the main components for storage.

Sessions are intended to work in conjunction with other objects to
do their work; a Session can't send a message without the assistence
of a Protocol, for instance. Consequently, ideally, there won't be
a need for another Thrasher::Session implementation, since all
the protocol-varying stuff should live in the Thrasher::Protocol
implementations.

The design of this object is a bit weird, since it sort of ends
up filling in the cracks between Protocols, Backends, and the
Component, where the first two are designed primarily to be easily
replacable, not in accordance with any other OO design
principles. This badly distorts the design, and Thrasher::Session is
what ends up paying the piper.

As an example, see C<add_contact>, which implements the I<logic> for
adding a contact, but has to do it entirely in terms of methods
offered by the Protocol, Component, and Backend objects.

=cut

use Thrasher::XML qw(strip_resource extract_disco_info);
use Thrasher::Constants qw(:all);
use Thrasher::Callbacks qw(:all);
use Thrasher::Log qw(:all);

use Data::Dumper;

my $id_counter = 1;

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

    $self->{full_jid} = shift;
    $self->{jid} = strip_resource($self->{full_jid});
    $self->{component} = shift;
    $self->{protocol} = shift;
    $self->{legacy_login} = shift;
    $self->{status} = '';

    $self->{internal_id} = $id_counter++;

    # When a session is created, fire a discovery request at the
    # creating JID.
    $self->{component}->iq_query
        ([[$NS_COMPONENT, 'iq'],
          {to => $self->{full_jid},
           from => $self->{component}->{component_name},
           type => 'get'},
          [[[$NS_DISCO_INFO, 'query'], {}, []]]],
          sub {
              my $component = shift;
              my $iq_params = shift;
              my $iq_packet = shift;

              if ($iq_params->{type} eq 'error') {
                  failed("client_discovery_" . $self->{internal_id});
                  return;
              }

              # And process the answer; check for 'error'
              my ($identities, $features) = 
                  extract_disco_info($iq_params->{query});
              my %features_hash = map { $_ => 1 } @$features;

              $self->{client_identities} = $identities;
              $self->{client_features} = \%features_hash;

              succeeded("client_discovery_" . $self->{internal_id});
         });

    return $self;
}

sub set_lang {
    my $self = shift;
    my $lang = shift;
    if (!$self->{_xml_lang}) {
        $self->{_xml_lang} = $lang;
    }
}

sub get_lang {
    my $self = shift;
    # Sorry, everybody else... but there can only be one default.
    return $self->{_xml_lang} || 'en';
}

sub logout {
    my $self = shift;

    # Cleanup its usage of the callback for this session, so that
    # hash entry doesn't leak.
    event_superceded("client_discovery_" . $self->{internal_id});
    event_superceded("legacy_login_" . $self->{internal_id});
}

# Do something, if and only if we find that the given feature
# is supported.
sub do_if_feature {
    my $self = shift;
    my $feature_or_features = shift;
    my $success_function = shift;
    my $failure_function = shift;

    my $features_discovered = sub {
        if (ref($feature_or_features) eq 'ARRAY') {
            for my $feature (@$feature_or_features) {
                if (!$self->{client_features}->{$feature}) {
                    if ($failure_function) {
                        $failure_function->('missing_feature',
                                            $feature);
                    }
                    return;
                }
            }
        } elsif (!$self->{client_features}->{$feature_or_features}) {
            if ($failure_function) {
                $failure_function->('missing_feature',
                                    $feature_or_features);
            }
            return;
        }

        $success_function->();
    };

    my $features_not_discovered = sub {
        if ($failure_function) {
            $failure_function->('no_disco');
        }
    };

    do_when("client_discovery_" . $self->{internal_id},
            $features_discovered, $features_not_discovered);
}

# Implementing section 4.6
sub subscribe {
    my $self = shift;
    my $jid = shift;

    # FIXME - should use the protocol for translating names here
    my $legacy_username = $self->{protocol}->{backend}->jid_to_legacy_name
        ($self->{jid}, $jid);
    if (!defined($legacy_username)) {
        # FIXME: Error out.
        return;
    }

    # Handle the subscription request, if it is successful
    my $handle_subscription = sub {
        my $subscription_successful = shift;

        my $comp = $self->{component};
        my $this_jid = $self->{jid};
        my $target_jid = $jid;

        if ($subscription_successful) {
            # 4.6 #3, subscription successful
            $comp->send_presence_xml($this_jid, 'subscribed', $target_jid);

            # Spec violation: XEP-0100 assumes that the user is
            # online, we actually pass through the real presence we got.
            if (my $stored_presence =
                delete
                $self->{presence_waiting_for_subscribe}->{$legacy_username})
            {
                if ($stored_presence->[0]
                      && $stored_presence->[0] eq 'unavailable') {
                    # 4.6 #4, send available. But only *if* we're
                    # sending unavailable immediately after. Client
                    # may become suspicious and show the subscription
                    # as "ask"/waiting for auth if a contact that
                    # supposedly authorized was never online until
                    # that contact was next seen login.
                    $comp->send_presence($self->{jid}, $legacy_username);
                }
                log("Using stored presence information for $legacy_username");
                $comp->send_presence($self->{jid}, $legacy_username,
                                     @$stored_presence);
            } else {
                log("no stored presence information for $legacy_username found.");
            }

            # 4.6 #5
            $comp->send_presence_xml($this_jid, 'subscribe', $target_jid);

            # 4.6 #6, WTF? You can't do this, the legacy user doesn't
            # get XML stanzas...? Psi seems to agree, so 
            # XEP-0100 violation, we don't send this.
            # FIXME: Mail the standards list about this.
            #$comp->send_presence_xml($target_jid, 'subscribed', $this_jid);

            # Update the roster information
            my $legacy_username = 
                $comp->{protocol}->{backend}->jid_to_legacy_name($self->{jid},
                                                     $target_jid);
            $comp->{protocol}->{backend}->set_roster_user_state
                ($self->{jid}, $legacy_username, 
                 $comp->{protocol}->{backend}->subscribed);
        } else {
            # Unsuccessful subscription, assumed to be because the
            # legacy user rejected it. Section 4.6.2.
            $comp->send_presence_xml($this_jid, 'unsubscribed', $target_jid);
        }
    };

    my $legacy_id =
        $self->{protocol}->{backend}->jid_to_legacy_name($self->{jid}, $jid);

    $self->{protocol}->subscribe($self, $legacy_id, $handle_subscription);
}

# Implementing section 4.7
sub unsubscribe {
    my $self = shift;
    my $jid = shift;

    # FIXME: Should use the protocol for name translation here
    my ($user_name) = split(/\@/, $jid);
    if (!defined($user_name)) {
        # FIXME: Error
    }

    # We assume subscription is successful, because XMPP assumes it is
    my $handle_unsubscription = sub {
        my $comp = $self->{component};
        my $this_jid = $self->{jid};
        my $target_jid = $jid;

        $comp->send_presence_xml($target_jid, 'unsubscribe', $this_jid);
        $comp->send_presence_xml($target_jid, 'unsubscribed', $this_jid);
        $comp->send_presence_xml($this_jid, 'unavailable', $target_jid);

        # Update the roster information
        my $legacy_username = 
            $comp->{protocol}->{backend}->jid_to_legacy_name($self->{jid},
                                                 $target_jid);
        $comp->{protocol}->{backend}->set_roster_user_state
            ($self->{jid}, $legacy_username, 
             $comp->{protocol}->{backend}->unsubscribed);
    };

    my $legacy_id =
        $self->{protocol}->{backend}->jid_to_legacy_name($self->{jid}, $jid);

    $self->{protocol}->unsubscribe($self, $legacy_id, $handle_unsubscription);
}

sub is_registered {
    my $self = shift;
    return $self->{protocol}->{backend}->registered($self->{jid});
}

sub on_connection_complete {
    my ($self, $callback) = @_;

    do_when('legacy_login_' . $self->{'internal_id'},
            $callback);
}

1;