perl/lib/Thrasher/Plugin/Basic.pm

   1 package Thrasher::Plugin::Basic;
   2 use strict;
   3 use warnings;
   4
   5 use Thrasher::Plugin qw(:all);
   6 use Thrasher::Constants qw(:all);
   7 use Thrasher::XML qw(:all);
   8 use Thrasher::XMPPStreamIn qw(:all);
   9 use Thrasher::Log qw(:all);
  10
  11 =pod
  12
  13 =head1 NAME
  14
  15 Thrasher::Plugin::Basic - the basic plugins for the component.
  16
  17 =head1 DESCRIPTION
  18
  19 This provides the basic plugins that the component must always
  20 support, or where the support is implemented in pure perl with
  21 no reference to the protocol (such as "time"). This is
  22 always used by the component.
  23
  24 =cut
  25
  26 sub component_identity_info {
  27     my $component = shift;
  28
  29     # Capability-ready info: CATEGORY, TYPE, LANG, NAME
  30     return ('gateway', lc $component->{protocol}->identifier, '',
  31             $component->{protocol}->name() . ' Gateway');
  32 }
  33
  34 sub client_identity_info {
  35     component_identity_info(@_);
  36 }
  37
  38 # Section 4.1: Registration
  39
  40 # Section 4.1.1
  41
  42 # TODO: Handle the old agent information protocol (example 2 and 4)
  43
  44 # Handle the true discovery protocol
  45 register_plugin({component_iq_handlers =>
  46                      {$NS_DISCO_INFO =>
  47                           {get => \&handle_disco_info}},
  48                  client_iq_handlers =>
  49                      {$NS_DISCO_INFO =>
  50                           {get => \&handle_disco_info}},
  51                  features => [$NS_DISCO_INFO]});
  52 sub handle_disco_info {
  53     my $component = shift;
  54     my $iq_params = shift;
  55     my $iq_tag = shift;
  56
  57     my @identity_info = component_identity_info($component);
  58     my @supported_features = supported_features;
  59
  60     my $node = $iq_params->{query}->[1]->{'{}node'};
  61
  62     my ($category, $type, $lang, $name) = @identity_info;
  63
  64     # We get here with queries corresponding to Example 1
  65     my $reply = [[$NS_DISCO_INFO, 'query'], {($node ? (node => $node) : ())},
  66                  [
  67                   [[$NS_DISCO_INFO, 'identity'],
  68                    {category => $category,
  69                     type => $type,
  70                     name => $name},
  71                    []],
  72                   map { feature($_) } @supported_features,
  73                   ]];
  74     # Reply with Example 3
  75     $component->iq_reply($iq_params, $reply);
  76 }
  77
  78 register_plugin({component_iq_handlers =>
  79                  {$NS_DISCO_ITEMS =>
  80                       {get => \&handle_disco_items}},
  81                  client_iq_handlers =>
  82                  {$NS_DISCO_ITEMS =>
  83                       {get => \&handle_disco_items}},
  84                  features => [$NS_DISCO_ITEMS]});
  85 sub handle_disco_items {
  86     my $self = shift;
  87     my $iq_params = shift;
  88
  89     # We have no items.
  90     my $reply = [[$NS_DISCO_ITEMS, 'query'], {}, []];
  91     $self->iq_reply($iq_params, $reply);
  92 }
  93
  94 # 4.1.1 3 and 4 - handle In-Band Registration
  95 register_plugin({component_iq_handlers =>
  96                  {$NS_REGISTER => {set => \&handle_register,
  97                                    get => \&handle_register}},
  98                  features => [$NS_REGISTER]});
  99 sub handle_register {
 100     my $self = shift;
 101     my $iq_params = shift;
 102
 103     my $base_from = strip_resource($iq_params->{from});
 104
 105     # This handles the mechanics of unregistering.
 106     my $actually_unregister = sub {
 107         $self->{protocol}->remove($base_from);
 108         $self->iq_reply($iq_params);
 109         $self->send_presence_xml($iq_params->{from}, 'unsubscribe');
 110         $self->send_presence_xml($iq_params->{from}, 'unsubscribed');
 111         $self->send_presence_xml($iq_params->{from}, 'unavailable');
 112
 113         # Hack; do we need to do something more
 114         # for optional callbacks?
 115         if (my $callback =
 116             $Thrasher::Component::UNREGISTER_CALLBACK)
 117         {
 118             log "Calling callback\n";
 119             local $@;
 120             eval { $callback->($base_from); };
 121         } else {
 122             log "Callback not found.\n";
 123         }
 124     };
 125
 126     # And this performs the bookkeeping around it.
 127     my $unregister = sub {
 128         my $session = $self->session_for($iq_params->{from});
 129
 130         # If I'm currently "logged in", I want to finish
 131         # disconnecting before I report to the user
 132         # that they are disconnected; if they are not
 133         # "logged in", we can immediately unregister.
 134         if (defined($session)) {
 135             $self->logout($session, $actually_unregister);
 136         } else {
 137             if ($self->registration_info($base_from)) {
 138                 $actually_unregister->();
 139             } else {
 140                 # What do you mean, "unregister"? I
 141                 # don't even know you! A little odd
 142                 # to fire "registration required"
 143                 # to unregister, but it fits best...
 144                 $self->iq_error($iq_params,
 145                                 'registration_required');
 146             }
 147         }
 148     };
 149
 150     multi_extract($iq_params->{query},
 151
 152                   # Example 5 - query registration,
 153                   # reply with Example 6
 154                   [[$NS_REGISTER, 'query'], {}, []] =>
 155                   sub {
 156                       $self->iq_reply($iq_params,
 157                                       [[$NS_REGISTER, 'query'],
 158                                        {},
 159                                        $self->{protocol}->registration_xml(strip_resource($iq_params->{from}))]);
 160                   },
 161
 162                   # Unregistering - Section 4.3
 163                   [[$NS_REGISTER, 'query'], {},
 164                    save_match([[$NS_REGISTER, 'remove'], undef,
 165                    undef])] =>
 166                   sub {
 167                       $unregister->();
 168                   },
 169
 170                   # User is registering - 4.1.1 #5 and 4.2.1 #3
 171                   [[$NS_REGISTER, 'query'], undef,
 172                    save_sub('children',
 173                             sub { ref($_[0]) eq 'ARRAY' ? $_[0] : undef})] =>
 174                   sub {
 175                       my $children = $_[0]->{children};
 176
 177                       my $registration_info = {};
 178
 179                       # Process the children
 180                       for my $child (@$children) {
 181                           my $subchildren = $child->[2];
 182                           if (has_subtags($subchildren)) {
 183                               $self->iq_error($iq_params, 'bad_request');
 184                               return;
 185                           }
 186                           my $tag_name = $child->[0]->[1];
 187                           $registration_info->{$tag_name} =
 188                               join '', @$subchildren;
 189                       }
 190
 191                       # add in the defaults as needed
 192                       my $protocol = $self->{protocol};
 193                       my $backend = $protocol->{backend};
 194                       my $registration_defaults =
 195                           $protocol->registration_defaults;
 196
 197                       for my $item (keys %$registration_defaults) {
 198                           if (!defined($registration_info->{$item})) {
 199                               # If we added a field in a new version, hopefully it
 200                               # has a new default to go with it. If so, apply it.
 201                               if (defined($registration_defaults->{$item})) {
 202                                   $registration_info->{$item} =
 203                                       $registration_defaults->{$item};
 204                               }
 205                           }
 206                       }
 207
 208                       my $current_registration =
 209                           $backend->registered
 210                           (strip_resource($iq_params->{from}));
 211                       if ($current_registration) {
 212                           # If the user is already registered, see if
 213                           # they changed anything. If not, ignore it.
 214                           # If so, start by unregistering.
 215                           if (hash_equals($current_registration,
 216                                           $registration_info)) {
 217                               $self->iq_reply($iq_params);
 218                               return;
 219                           } else {
 220                               # Perhaps surprisingly, the entire
 221                               # unregistration process is synchronous.
 222                               $unregister->();
 223                           }
 224                       }
 225
 226                       # HACK: Allow unregistration by registering
 227                       # an empty username. While this is not
 228                       # compliant with the XEP-0100 protocol, it
 229                       # is a reasonable digression, IMHO, and many
 230                       # clients make it either impossible to
 231                       # correctly unregister, or make it a lot less
 232                       # obvious than just toasting your credentials.
 233                       # I think this is the best interpretation of
 234                       # this action by far.
 235                       if ($registration_info->{username} eq '') {
 236                           $unregister->();
 237                           return;
 238                       }
 239
 240                       # This handles 4.1.1 and 4.2.1 registration
 241                       # in the protocol interface, by requiring
 242                       # protocol implementations to return correctly
 243                       # formatted registration replies OR errors.
 244                       my ($successful, $error) =
 245                           $self->{protocol}->registration(strip_resource($iq_params->{from}), $registration_info);
 246                       if ($successful) {
 247                           $self->iq_reply($iq_params);
 248                           $self->send_presence_xml($iq_params->{from}, 'subscribe');
 249                           $self->send_presence_xml($iq_params->{from}, 'probe');
 250                       } else {
 251                           # Section 4.1.2 if the info fails to
 252                           # verify.
 253                           $self->iq_error($iq_params, $error ||
 254                                                       'bad_request');
 255                       }
 256                   },
 257
 258                   $self->no_match("in iq for $NS_REGISTER", $iq_params));
 259 }
 260
 261 register_plugin({component_iq_handlers => {$NS_GATEWAY =>
 262                                            {set => \&handle_gateway,
 263                                             get => \&handle_gateway}}});
 264 sub handle_gateway {
 265     my $self = shift;
 266     my $iq_params = shift;
 267     my $iq_packet = shift;
 268
 269     # FIXME: Did the lang matching work? Use that.
 270     my $lang = $iq_packet->[1]->{"{$NS_XML}lang"} || 'en';
 271
 272     my $children = extract([undef, undef,
 273                             save_sub('children',
 274                                      sub { ref($_[0]) ? $_[0] : undef },
 275                                      1)],
 276                            $iq_params->{query});
 277
 278     # User made a query.
 279     if (@{$children->{children}}) {
 280         my ($prompt) = grep { $_->[0]->[1] eq 'prompt' } @{$children->{children}};
 281
 282         if (!$prompt) {
 283             # Had subtags, but no prompt? Error.
 284             $self->iq_error($iq_params, 'bad_request');
 285             return;
 286         }
 287
 288         my $prompt_strings =
 289             extract([undef, undef,
 290                      save_sub("legacy_name", \&text_extractor)],
 291                     $prompt);
 292         my $legacy_name = join '', @{$prompt_strings->{legacy_name}};
 293         my $jid = $self->legacy_name_to_xmpp
 294             (strip_resource($iq_params->{from}), $legacy_name,
 295              $self->{component_name}, $lang);
 296
 297         my $reply = [[$NS_GATEWAY, 'query'], {},
 298                      [[[$NS_GATEWAY, 'jid'], {}, [$jid]],
 299                       # PSI at the very least, possibly others,
 300                       # expect the answer in the 'prompt', bleh
 301                       [[$NS_GATEWAY, 'prompt'], {}, [$jid]]]];
 302         $self->iq_reply($iq_params, $reply);
 303         return;
 304     }
 305
 306
 307     my $protocol = $self->{protocol};
 308     my $desc = $protocol->gateway_desc($lang);
 309     my $prompt = $protocol->gateway_prompt($lang);
 310
 311     my $reply = [[$NS_GATEWAY, 'query'], {},
 312                  [[[$NS_GATEWAY, 'prompt'], {}, [$prompt]],
 313                   (defined($desc) ?
 314                    ([[$NS_GATEWAY, 'desc'], {}, [$desc]])
 315                    : ())
 316                   ]];
 317     $self->iq_reply($iq_params, $reply);
 318 }
 319
 320 register_plugin({component_iq_handlers => {$NS_TIME => {get => \&handle_time}},
 321                  client_iq_handlers => {$NS_TIME => {get => \&handle_time}},
 322                  features => [$NS_TIME]});
 323 sub handle_time {
 324     my $self = shift;
 325     my $iq_params = shift;
 326     my $iq_packet = shift;
 327
 328     # "gmtime" gets the UTC time
 329     my ($sec, $min, $hour, $mday, $mon, $year) = gmtime;
 330     $year += 1900;
 331     my $utc_time = sprintf("%04d%02d%02dT%02d:%02d:%02d",
 332                            $year, $mon + 1, $mday, $hour, $min, $sec);
 333
 334     # I choose to decline to send the other elements because they are
 335     # worthless; a client should convert the utc time into local time
 336     # if they care, and XEP-0090 fails to specify an *unambigiuous*
 337     # timezone format.
 338     my $reply = [[$NS_TIME, 'query'], {},
 339                  [[[$NS_TIME, 'utc'], {}, [$utc_time]]]];
 340     $self->iq_reply($iq_params, $reply);
 341 }
 342
 343 register_plugin({component_iq_handlers => {$NS_VERSION => {get => \&handle_version}},
 344                  client_iq_handlers => {$NS_VERSION => {get => \&handle_version}},
 345                  features => [$NS_VERSION]});
 346 sub handle_version {
 347     my $self = shift;
 348     my $iq_params = shift;
 349
 350     my $reply = [[$NS_VERSION, 'query'], {},
 351                  [[[$NS_VERSION, 'name'], {},
 352                    ['Thrasher - ' . $self->{component_name}]],
 353                   [[$NS_VERSION, 'version'], {},
 354                    [$Thrasher::VERSION]]]];
 355     $self->iq_reply($iq_params, $reply);
 356 }
 357
 358 # Ignore some namespaces we don't support and don't want to see error
 359 # messages for
 360 register_plugin({component_iq_handlers => {$NS_LAST => {get => "ignore"}}});
 361
 362 # hate depending on a library for this
 363 sub hash_equals {
 364     my $a = shift;
 365     my $b = shift;
 366
 367     my @a_keys = keys %$a;
 368     my @b_keys = keys %$b;
 369
 370     if (scalar(@a_keys) != scalar(@b_keys)) {
 371         return 0;
 372     }
 373
 374     for my $a_key (@a_keys) {
 375         if (!exists($b->{$a_key}) ||
 376             $a->{$a_key} ne $b->{$a_key}) {
 377             return 0;
 378         }
 379     }
 380
 381     return 1;
 382 }
 383
 384 1;