perl/lib/Thrasher/Plugin/EntityCapabilities.pm

   1 package Thrasher::Plugin::EntityCapabilities;
   2 use strict;
   3 use warnings;
   4
   5 =pod
   6
   7 =head1 NAME
   8
   9 Thrasher::Plugin::EntityCapabilities - add XEP-0115 "Entity
  10 Capabilities" support.
  11
  12 =head1 DESCRIPTION
  13
  14 This plugin adds support for XEP-0115, "Entity Capabilities". This
  15 automatically implements support for the capabilities as described
  16 by the data in Thrasher::Plugin, and should need no further
  17 interaction beyond "use"ing this module if needed. It automatically
  18 annotates outgoing presence packets with the appropriate <c> tag.
  19
  20 =cut
  21
  22 use Thrasher::Plugin qw(:all);
  23 use Thrasher::Constants qw(:all);
  24 use Thrasher::Log qw(log);
  25 use Thrasher::XML qw(:all);
  26 use Thrasher::Callbacks qw(:all);
  27
  28 use Digest::SHA1 qw(sha1_base64);
  29
  30 use base 'Exporter';
  31
  32 our @EXPORT_OK = qw(has_feature has_identity_category);
  33 our %EXPORT_TAGS = (all => \@EXPORT_OK);
  34
  35 my $CURRENT_CAP_HASH;
  36
  37 # set-like hash of features
  38 our %SERVER_FEATURES;
  39 our @SERVER_IDENTITIES;
  40
  41 sub has_feature { $SERVER_FEATURES{$_[0]}; }
  42
  43 sub has_identity_category { grep { $_->[0] eq $_[0] } @SERVER_IDENTITIES }
  44
  45 # At the time that the plugins are updated, we don't have a component.
  46 # Mark that updates are needed, and on the next presence callback
  47 # (which will have a component), we'll compute it.
  48 my $UPDATE_NEEDED = 1;
  49
  50 register_plugin({features => [$NS_CAPS],
  51                  callbacks =>
  52                    {plugins_changed =>
  53                      {entity_caps => \&update_needed},
  54                     presence_out =>
  55                      {entity_caps => \&presence_out},
  56                     connected =>
  57                      {entity_caps => \&query_server_capabilities}}});
  58
  59 # This currently has no support for extended service discovery forms
  60 # since we have none.
  61 sub hash_for_caps {
  62     my $identity_info = shift;
  63     my $supported_features = shift;
  64
  65     my $s = join('/', @$identity_info) . '<';
  66
  67     for my $service_discovery_identity (@$supported_features) {
  68         $s .= $service_discovery_identity . '<';
  69     }
  70
  71     return sha1_base64($s);
  72 }
  73
  74 sub update_caps {
  75     my $component = shift;
  76     my @identity_info =
  77         Thrasher::Plugin::Basic::component_identity_info($component);
  78     my @supported_features = supported_features;
  79     $CURRENT_CAP_HASH = hash_for_caps
  80         (\@identity_info, \@supported_features);
  81 }
  82
  83 sub update_needed {
  84     $UPDATE_NEEDED = 1;
  85 }
  86
  87 sub run_update {
  88     my $component = shift;
  89     update_caps($component);
  90     $UPDATE_NEEDED = 0;
  91 }
  92
  93 # Add the caps tag to the presence
  94 sub presence_out {
  95     my $component = shift;
  96     my $presence_tag = shift;
  97
  98     if ($UPDATE_NEEDED) {
  99         run_update($component);
 100     }
 101
 102     my $from = $presence_tag->[1]->{from};
 103
 104     my $c = [[$NS_CAPS, 'c'],
 105              {hash => 'sha-1',
 106               node =>
 107                   'http://developer.berlios.de/projects/thrasher/',
 108               ver => $CURRENT_CAP_HASH},
 109              []];
 110     push @{$presence_tag->[2]}, $c;
 111
 112     return 1;
 113 }
 114
 115 # When we connect, query the server for its capabilities, which will
 116 # be necessary for other plugins
 117 sub query_server_capabilities {
 118     my $component = shift;
 119
 120     # Query the server for its capabilities.
 121     my $iq_packet = [[$NS_COMPONENT, 'iq'],
 122                      {type => "get",
 123                       from => $component->{component_name},
 124                       to => $Thrasher::SERVER_NAME || ''}, # blank if testing
 125                      [[[$NS_DISCO_INFO, 'query'], {}, []]]];
 126
 127     $component->iq_query($iq_packet, \&extract_server_caps);
 128 }
 129
 130 sub extract_server_caps {
 131     my $component = shift;
 132     my $iq_params = shift;
 133     my $iq_packet = shift;
 134
 135     if ($iq_params->{'type'} eq 'error') {
 136         log("extract_server_caps: error from $iq_params->{from}");
 137         failed('server_capabilities_detected');
 138         return;
 139     }
 140
 141     my $query = $iq_params->{query};
 142
 143     my ($identities, $features) = extract_disco_info($query);
 144
 145     @SERVER_IDENTITIES = @$identities;
 146     %SERVER_FEATURES = map { $_ => 1 } @$features;
 147
 148     succeeded('server_capabilities_detected');
 149 }
 150
 151 1;