1 package Thrasher
::Component
;
9 Thrasher::Component - tie together XML stream processing and component
10 state into one module to handle a single "component"
14 Thrasher::Component implements a XEP-0100 compliant component, with
15 hooks for adding further stuff into the component in a defined
16 way. The component is primarily "private" and documented in comments,
17 but this POD will document two things: The interface for the
18 Thrasher::Protocol implementations, and the hooks provided
19 for extending the base XEP-0100 protocol.
23 # General overview of this file: Some support code for the component
24 # is written in the front, then after the
25 ###### PROTOCOL SUPPORT
26 # comment below, we'll be implementing the component protocol
27 # by following along the specification at
28 # http://www.xmpp.org/extensions/xep-0114.html
29 # which will be referenced by section number.
31 # This file should only implement the bare minimum protocol stuff;
32 # additional capabilities should live elsewhere, just to avoid this
33 # file getting pointlessly large, and to avoid mixing extensions
34 # in with the XEP-0100 stuff.
36 # Right now this only permits one protocol per connection, but
37 # I'm trying to structure this for multi-protocol support in the
38 # future, per the later XEP on components.
40 use Thrasher
::Log
qw(:all);
41 use Thrasher
::XMPPStreamOut
;
42 use Thrasher
::XMPPStreamIn
qw(:all);
43 use Thrasher
::Constants
qw(:all);
44 use Thrasher
::Plugin
qw(:all);
45 use Thrasher
::XML
qw(:all);
46 use Thrasher
::ConnectionManager
qw(:all);
47 use Thrasher
::XHTML_IM_Normalize
qw(xhtml_and_text text);
48 use Thrasher
::Callbacks
qw(:all);
50 use Thrasher
::Plugin
::Basic
;
53 use Carp
qw(confess longmess);
56 use Digest
::SHA1
qw(sha1_hex);
60 our @EXPORT_OK = qw(feature
61 has_subtags strip_resource no_match);
62 our %EXPORT_TAGS = (all
=> \
@EXPORT_OK);
64 my $DEBUG = $Thrasher::DEBUG
;
66 # This indicates whether or not to use the connection manager to
67 # prevent flooding and to tell whether or not the remote service is
68 # having trouble. This should generally only be turned off for
69 # debugging purposes, but it could be useful in other scenarios.
70 our $USE_CONNECTION_MANAGER = 1;
72 # For testing purposes, this allows use to simply tell the component
73 # whether it is getting directly connected or not, so we can
74 # test the XML output it is supposed to generate. In real execution
75 # this should never be set.
76 our $WILL_BE_DIRECTLY_CONNECTED = undef;
78 # Hmm, this isn't good, but ProxyFileTransfer needs it. When/if
79 # we ever want to run multiple components out of one protocol we
83 # This manages the input from and the output to the component, but is
84 # not responsible for managing the socket; it receives XML text and
85 # is expected to output XML text. This, again, allows us to trivially
86 # test this component in a unit test environment without having to
87 # connect to a real XMPP server.
89 # Text is received by this object by calling "->text_in". Text out
90 # is sent out along the closure received during object construction,
91 # converted through Thrasher::XMPPStreamOut into text. A
92 # method ->xml_out accepts XML for output, but should be internal-only.
94 # used to make unique IDs
97 return "id" . ($id++);
100 # States change mostly during connection. This changes which
101 # functions are passed the incoming XML events.
103 'disconnected' => sub { },
104 connecting
=> \
&xml_in_connecting
,
105 handshaking
=> \
&xml_in_handshaking
,
106 connected
=> \
&xml_in_connected
114 $self->{protocol
} = shift;
115 if (!UNIVERSAL
::isa
($self->{protocol
}, 'Thrasher::Protocol')) {
116 die "The first argument to the component needs to be "
117 ."a Thrasher::Protocol instance.";
120 my $text_output_closure = shift;
121 if (ref($text_output_closure) ne 'CODE') {
122 die "Creating a component requires a closure for the output"
125 $self->{output
} = $text_output_closure;
127 $self->setup_streams;
129 # Need info for the stream connect
130 $self->{secret
} = shift;
131 $self->{component_name
} = shift;
133 $self->{state} = 'disconnected';
134 $self->{xml_buf
} = [];
136 # This holds a jid => {registration_info => $registration_info,
137 # error_xml => $xml_tag} hash. If we get a login request, but
138 # we've already tried that registration info and the remote
139 # service told us it's bad, we don't re-try it. This is
140 # deliberately held in transient memory storage.
141 $self->{authentication_errors
} = {};
151 my $out_stream = new Thrasher
::XMPPStreamOut
($self->{output
});
152 $self->{out_stream
} = $out_stream;
154 my $in_stream = Thrasher
::XMPPStreamIn
::get_parser
();
155 $self->{in_stream
} = $in_stream;
158 # The usual xml_out used for most traffic, will buffer the
159 # XML if we're not currently connected.
163 if ($self->{state} ne 'connected') {
164 push @
{$self->{xml_buf
}}, @_;
167 $self->{out_stream
}->output(@_);
170 # xml_out used by connection routines, to force out the
171 # necessary handshaking.
174 $self->{out_stream
}->output(@_);
177 sub output_initial_stream_tag
{
181 [[$NS_STREAM, 'stream'],
182 {"{$NS_COMPONENT}to" => $self->{component_name
}},
184 $self->set_state('connecting');
185 # This is a direct call to output_tag_and_children so we can
186 # pass in the $is_root_element value, which this needs.
187 $self->{out_stream
}->output_tag_and_children($initial_stream, 1);
190 # Once we know we're connected, probe everybody in our list
191 sub initialize_connection
{
194 if ($self->{initialized
}) {
195 log("Already initialized connection.");
199 $self->{initialized
} = 1;
201 log("Initializing connection");
203 my $backend = $self->{protocol
}->{backend
};
204 my $all_jids = $backend->all_jids;
206 for my $jid (@
$all_jids) {
207 $self->send_presence_xml($jid, 'probe');
210 # Send a discovery request at the server, which we
211 # then recurse down one level to get the info for
213 # But only do it if we have a SERVER NAME.
214 if ($Thrasher::SERVER_NAME
) {
216 ([[$NS_COMPONENT, 'iq'],
217 {to
=> $Thrasher::SERVER_NAME
,
218 from
=> $self->{component_name
},
220 [[[$NS_DISCO_ITEMS, 'query'], {}, []]]],
222 my $component = shift;
223 my $iq_params = shift;
224 my $iq_packet = shift;
226 if ($iq_params->{type
} eq 'error') {
227 # FIXME: Schedule a timeout to try again.
228 log("Server discovery failed, this may cause "
229 ."odd, random problems.");
230 failed
("server_discovery_items");
235 extract_disco_items
($iq_params->{query
});
236 my %items_hash = map { $_ => 1} @
$items;
238 my $item_count = scalar(@
$items);
240 # For each item, fire off an info request
241 for my $item (@
$items) {
242 if ($item eq $self->{component_name
}) {
248 ([[$NS_COMPONENT, 'iq'],
250 from
=> $self->{component_name
},
252 [[[$NS_DISCO_INFO, 'query'], {}, []]]],
254 my $component = shift;
255 my $iq_params = shift;
256 my $iq_packet = shift;
257 debug
("Disco info got $iq_params->{type} from $item"
258 . " with $item_count remaining.");
260 if ($iq_params->{type
} ne 'error') {
261 my ($identities, $features) =
262 extract_disco_info
($iq_params->{query
});
263 $Thrasher::SERVER_INFO
->{$item} =
264 [$identities, $features];
266 # Server was configured to return this
267 # existed, but it doesn't seem to.
268 # Hopefully the proxy service isn't
270 delete $Thrasher::SERVER_INFO
->{$item};
275 if ($item_count == 0) {
276 succeeded
("server_discovery_items");
279 # Ensure server_discovery_items callbacks fire
280 # eventually even when some component doesn't reply.
281 # That would be one evil component...
282 my $no_reply_check_timeout = sub {
284 if ($item_count == scalar(@
{$items})) {
285 # ...not a single component responded?!!
286 failed
('server_discovery_items');
288 elsif ($item_count > 0) {
289 # ...got some responses, but not all.
290 # Give what we have to success callbacks--if
291 # we luck out the missing component(s) aren't
292 # the ones they need.
293 succeeded
('server_discovery_items');
295 return 0; # never repeat.
297 $self->{'event_loop'}->schedule($no_reply_check_timeout,
305 my ($self, $state) = @_;
306 $self->{state} = $state;
308 if ($state eq 'connected') {
309 log("State set to 'connected'");
310 $self->initialize_connection;
318 my $state_xml_func = $states->{$self->{state}};
319 if (!defined($state_xml_func)) {
320 die "Receiving xml, but I don't have a handler for "
321 ."state '" . $self->{state} . "', how odd! (1)";
324 my $parsed = $self->{in_stream
}->parse($xml);
325 for my $message (@
$parsed) {
326 $state_xml_func->($self, $message);
328 # State may change after processing a message
329 $state_xml_func = $states->{$self->{state}};
330 if (!defined($state_xml_func)) {
331 die "Receiving xml, but I don't have a handler for "
332 ."state '" . $self->{state} . "', how odd! (2)";
340 ## State handlers; mostly for connection, as once we're connected
341 ## this component is basicly in a steady state. (The individual
342 ## connections are more complicated, but not this.)
345 my $STREAM = [$NS_STREAM, 'stream'];
346 my $HANDSHAKE = [$NS_COMPONENT, 'handshake'];
348 # In this state, we've sent the original <stream:stream ...> tag,
349 # and we're expecting the stream tag from the server
350 sub xml_in_connecting
{
352 my $xml_message = shift;
358 # Expected case - stream returned from the server.
359 # Annoyingly, we can't really check for stream errors
360 # at this level, since the stream tag is exactly the
361 # same for success and failure, EXCEPT that we get
362 # an additional error tag upon failure.
363 [$STREAM, {from
=> save
('host'), id
=> save
('stream_id')}] =>
365 # Server is on the track we expect, send out the
368 my $handshake = lc(sha1_hex
($params->{stream_id
}
370 $self->set_state('handshaking');
372 $self->force_xml_out([$HANDSHAKE, {}, [$handshake]]);
376 log("Error in stream tag? Reconnecting:\n$@\n");
377 $self->reconnect_stream();
381 sub xml_in_handshaking
{
383 my $xml_message = shift;
385 # If this passes, we're connected.
387 multi_extract
($xml_message,
388 [[$NS_COMPONENT, 'handshake'], {}, []] =>
390 $self->set_state('connected');
391 callbacks
('connected', $self);
394 [[$NS_STREAM, 'error'], {}, save
('text')] =>
397 die "Stream error after handshake. Server said: $params->{text}";
401 log("Handshake error; reconnecting:\n$@\n");
402 $self->reconnect_stream();
406 # In this state, we are connected, and are receiving arbitrary
407 # packets from arbitrary users.
408 sub xml_in_connected
{
410 my $xml_message = shift;
412 # Route the XML message according to the nature of the message.
413 multi_extract
($xml_message,
416 [[$NS_COMPONENT, 'iq'],
417 {type
=> save
("type"),
418 from
=> save
("from"),
421 "{$NS_XML}lang" => save
("language", 1)
423 # Save first child under "query" whether or not
424 # that's the actual tag name (e.g. "si").
425 save_match
('query', [undef, undef, undef], 1)] =>
427 my $iq_params = shift;
429 # Get and set handlers
430 return $self->handle_iq($iq_params,
434 [[$NS_COMPONENT, 'presence'],
437 callbacks
('presence_in',
439 sub { $self->handle_presence($_[0]) },
443 [[$NS_COMPONENT, 'message'], {
445 from
=> save
('from'),
446 type
=> save
('type', 1),
449 save_match
('chatstate',
450 [[$NS_CHATSTATES, undef], undef, undef],
453 [[undef, 'body'], undef, undef],
457 my $message_params = shift;
458 $message_params->{'type'} ||= 'chat';
459 if ($message_params->{'chatstate'}) {
460 $message_params->{'chatstate'}
461 = $message_params->{'chatstate'}->[0]->[1];
463 $self->handle_message($message_params->{to
},
464 $message_params->{from
},
465 $message_params->{body
},
466 $message_params->{'type'},
467 $message_params->{'chatstate'});
471 [[$NS_STREAM, 'error']] =>
473 my $children = $xml_message->[2];
475 for my $child (@
$children) {
476 if (ref($child) eq 'ARRAY') {
483 # No error tag? Shouldn't happen. Panic!
488 my $tag_name = $first_tag->[0]->[1];
489 # If it's a "not well formed" error,
490 # we can try to reconnect. If it's anything
492 if ($tag_name eq 'xml-not-well-formed') {
493 $self->reconnect_stream;
499 # Default handler - complain about the unknown
500 # packet, but otherwise ignore it.
503 log "Unexpected packet: " . Dumper
($xml_message);
508 # $IQ_CALLBACKS{"${jid_without_resource}-${id}"} => \&callback;
510 # The request/response ID (generated in iq_query()) includes the bare
511 # JID in case another user tries to inject a forged response.
516 my $iq_params = shift;
517 my $iq_packet = shift;
519 my $id = $iq_packet->[1]->{'{}id'};
521 my $request_id = strip_resource
($iq_params->{'from'}) . '-' . $id;
522 my $callback = $IQ_CALLBACKS{$request_id};
524 # Must not mistake unrelated requests using the same ID
525 # scheme for the expected response (e.g. two Thrasher
526 # instances doing server disco at the same time).
527 && $iq_params->{type
} =~ /^(?:result|error)$/) {
530 $callback->($self, $iq_params, $iq_packet);
532 log "IQ callback error: $@" if ($@
);
533 delete($IQ_CALLBACKS{$request_id});
537 if (! $iq_params->{query
}
538 || @
{$iq_params->{query
}} == 0
539 || @
{$iq_params->{query
}->[0]} == 0) {
540 # Unused and causes interesting issues when replying
541 # especially if autovivification occurs.
542 log('Skipping childless IQ: ' . Dumper
($iq_packet));
546 my $query_ns = $iq_params->{query
}->[0]->[0];
547 my $query_type = $iq_packet->[1]->{'{}type'};
548 my $target = 'client';
549 if (!defined($iq_params->{to
}) ||
550 $iq_params->{to
} eq $self->{component_name
}) {
551 $target = 'component';
553 my $func = method_for_iq_namespace
($target, $query_type, $query_ns);
555 # Allow ourselves to suppress the error for some namespaces.
556 if ($func && $func eq 'ignore') {
557 $self->iq_error($iq_params, 'service_unavailable');
561 if (!defined($func)) {
562 log "Unexpected IQ query: " . Dumper
($iq_params,
563 $target, $query_type,
565 if ($query_type ne 'error') {
566 # Prevent loop with error response to error generating an error....
567 $self->iq_error($iq_params, 'service_unavailable');
572 return $func->($self, $iq_params, $iq_packet);
577 # Everything but the ID
578 my $iq_packet = shift;
579 my $callback = shift;
582 $iq_packet->[1]->{id
} = $id;
585 # get_id() never repeats within a Thrasher instance so the only way
586 # we can get a duplicate ID in responses from the same bare JID
587 # is if the user sends two from different resources. Oh, well.
588 my $to = $iq_packet->[1]->{'to'}
589 || $iq_packet->[1]->{'{}to'}
591 my $request_id = strip_resource
($to) . '-' . $id;
592 $IQ_CALLBACKS{$request_id} = $callback;
595 $self->xml_out($iq_packet);
599 ###### PROTOCOL SUPPORT
602 sub send_presence_xml
{
604 my $target_jid = shift;
605 my $presence_type = shift;
606 my $from_jid = shift || $self->{component_name
};
611 # target_jid can be unset when the presence tag is coming
612 # from the transport itself
614 my $session = $self->session_for($target_jid);
615 if ($session && $session->{status
} eq 'disconnecting') {
616 # Don't send presence info for connections we're
617 # currently disconnecting.
618 log("Bypassing a presence from $from_jid because disconnecting");
624 no warnings
'uninitialized';
625 if ($target_jid eq $from_jid &&
626 $target_jid eq $self->{component_name
}) {
627 log("Attempt to send presence to self: " . longmess
);
630 if ($target_jid =~ /$self->{component_name}$/ &&
631 $from_jid =~ /$self->{component_name}$/) {
632 log("Attempting to send presence to self: "
633 . Dumper
($target_jid, $from_jid) .
640 push @children, [[$NS_COMPONENT, 'show'], {}, [$show]];
643 push @children, [[$NS_COMPONENT, 'status'], {}, [$status]];
646 push @children, @
$extra;
649 my $presence_out_tag = [[$NS_COMPONENT, 'presence'],
650 {($presence_type ?
(type
=> $presence_type) : ()),
652 ($target_jid ?
(to
=>
653 strip_resource
($target_jid)) : ())},
656 callbacks
('presence_out',
658 sub { $self->xml_out($_[0]) },
664 my $session_for = shift;
665 $session_for = strip_resource
($session_for);
666 return $self->{sessions
}->{$session_for};
669 sub set_session_for
{
670 my ($self, $jid, $session) = @_;
671 $jid = strip_resource
($jid);
673 $self->{'sessions'}->{$jid} = $session;
676 # Welcome to the ugliest function in all of Thrasher!
677 sub handle_presence
{
679 my $presence_tag = shift;
681 my ($element, $atts, $children) = @
$presence_tag;
683 for my $att qw(to from) {
684 if (!$atts->{"{}$att"}) {
685 log "Presence received with no '$att'; ignored.";
690 my $type = $atts->{'{}type'};
692 if ($type && $type eq 'error') {
693 log("Got a presence error.");
697 # Section 4.1.1 #10 - our request accepted
698 # FIXME: What if the request is rejected?
699 if (defined($type) &&
700 ($type eq 'subscribed' || $type eq 'unsubscribed') &&
701 (!defined($atts->{'{}to'}) ||
702 $atts->{'{}to'} eq $self->{component_name
})) {
707 if (defined($type) &&
708 $type eq 'subscribe' &&
709 $atts->{'{}to'} eq $self->{component_name
}) {
711 # Hey, sure, buddy, no problem
712 # FIXME: There ought to be something about registration here.
713 $self->xml_out([[$NS_COMPONENT, 'presence'],
714 {type
=> 'subscribed',
715 from
=> $self->{component_name
},
716 to
=> $atts->{'{}from'}},
721 if (defined($type) &&
722 $type eq 'unsubscribe' &&
723 $atts->{'{}to'} eq $self->{component_name
}) {
726 $self->xml_out([[$NS_COMPONENT, 'presence'],
727 {type
=> 'unsubscribed',
728 from
=> $self->{component_name
},
729 to
=> $atts->{'{}from'}},
734 # Everything above here is there because it can be
735 # done without a session; below this, a session
738 my $from = strip_resource
($atts->{'{}from'});
739 my $session = $self->session_for($from);
741 if (!defined($session) && $atts->{'{}type'}) {
742 if ($atts->{'{}type'} && $atts->{'{}type'} eq 'probe') {
744 $self->send_presence_xml($atts->{'{}from'},
749 my $registration_info =
750 $self->{protocol
}->{backend
}->registered($from);
752 if (!defined($registration_info)) {
753 if ($atts->{'{}from'} =~ /$self->{component_name}$/) {
754 # Don't reply to what is effectively ourself.
758 if ($atts->{'{}to'} ne $self->{component_name
}) {
759 # If this was a directed presence and it wasn't
760 # directly for the transport, eat it.
764 $self->xml_out([[$NS_COMPONENT, 'presence'],
765 {from
=> $self->{component_name
},
766 to
=> $atts->{'{}from'},
768 [error_tag
('registration_required')]]);
771 # A presence tag has been sent other than to log in,
772 # such as to subscribe, but the user is not currently
773 # logged in. If they are unsubscribing, go ahead
774 # and say they are unsubscribed. Otherwise, this
776 if ($atts->{'{}type'} eq 'unsubscribe') {
778 ([[$NS_COMPONENT, 'presence'],
779 {from
=> $atts->{'{}to'},
780 to
=> $atts->{'{}from'},
781 type
=> 'unsubscribed'}, []]);
785 # This gets sent out after logging off; if I can
786 # work out a way to distinguish that case vs.
787 # other cases where this would be called for, we can
789 $self->xml_out([[$NS_COMPONENT, 'presence'],
790 {from
=> $self->{component_name
},
791 to
=> $atts->{'{}from'},
793 [error_tag
('not_authorized')]]);
799 if (!defined($type)) {
800 if (!defined($session)) {
801 $self->login($atts->{'{}from'}, $presence_tag);
802 if ($atts->{'{}to'} ne $self->{component_name
}) {
806 $self->echo_presence($session, $presence_tag);
811 if ($type eq 'subscribe') {
812 $session->subscribe($atts->{'{}to'});
816 if ($type eq 'unsubscribe') {
817 $session->unsubscribe($atts->{'{}to'});
821 if ($type eq 'subscribed' || $type eq 'unsubscribed') {
822 my $protocol = $self->{protocol
};
824 $self->xmpp_name_to_legacy($atts->{'{}from'},
826 if (!defined($legacy_name)) {
827 log "No legacy name for " . $atts->{'{}to'};
830 $protocol->$type($session, $self, $legacy_name);
835 # FIXME: This conforms to the specification, but I think
836 # we ought to track which resources are online and only
837 # disconnect if the user has no resources online.
838 if ($type eq 'unavailable') {
839 if (!$atts->{'{}to'} ||
840 $atts->{'{}to'} eq $self->{component_name
}) {
841 $self->logout($session);
844 # Maybe we should just skip this?
845 log ("Presence unavailable not handled properly: "
851 if (defined($session)) {
852 $self->echo_presence($session, $presence_tag);
856 if ($type eq 'probe') {
857 # We know who you are.
858 $self->send_presence_xml($atts->{'{}from'}, '');
862 # This shouldn't be able to happen, all bases should be
864 log "Received unexpected presence packet with no "
865 . "associated session: \n" . Dumper
($presence_tag);
868 # Echos the presence of the user back out to the protocol, be
869 # it a general update or a targetted update.
873 my $presence_tag = shift;
875 my $type = $presence_tag->[1]->{'{}type'};
878 for my $child (@
{$presence_tag->[2]}) {
880 $child->[0]->[1] eq 'show') {
881 $show = join '', @
{$child->[2]};
884 $child->[0]->[1] eq 'status') {
885 $status = join '', @
{$child->[2]};
889 my $to = $presence_tag->[1]->{'{}to'};
890 if ($to eq $self->{component_name
}) {
891 $self->{protocol
}->user_presence_update
892 ($session, $type, $show, $status);
895 $self->xmpp_name_to_legacy(strip_resource
($presence_tag->[1]->{'{}from'}),
898 $self->{protocol
}->user_targeted_presence_update
899 ($session, $type, $show, $status, $target_user);
901 log "Sent targetted presence to user "
902 .$presence_tag->[1]->{'{}from'} . ", but I have no such user.";
909 my $full_jid = shift;
910 my $original_presence_tag = shift;
911 my $jid = strip_resource
($full_jid);
913 # Already queued a past login attempt. Tell that attempt to use
914 # the current full JID and don't enqueue another one.
915 if ($self->{'connection_queued'}->{$jid}) {
916 $self->{'connection_queued'}->{$jid} = $full_jid;
917 $self->send_connection_queued($jid);
921 my $registration_info = $self->{protocol
}->{backend
}->registered($jid);
923 if (my $error = $self->{authentication_errors
}->{$jid}) {
924 my $bad_registration_info = $error->{registration_info
};
925 if (compare_hashref
($bad_registration_info,
926 $registration_info)) {
927 # It looks like this only happens when users ask for it,
928 # so dump out the XML.
929 $self->xml_out($error->{error_xml
});
931 # Note there is one case this doesn't cover well; the user
932 # entered the wrong password, gets it labelled as bad,
933 # then actually CHANGES THE PASSWORD on the remote service
934 # to match this password. I'll worry when that happens,
935 # I guess, because right now the wrongness of pounding on
936 # the remote service outweighs that chance.
937 log("Discarding login attempt by $jid, because the "
938 ."same registration info has already been labelled "
939 ."as bad by the remote service.");
943 # It's a new registration, so try again. But first...
944 delete $self->{authentication_errors
}->{$jid};
947 my $login_handler = sub {
948 # Result from session can be:
949 # * ref (implies its the Session object)
951 # * undef if there was an error and the Protocol is handling it.
952 my ($session_or_error, $error_is_local_only) = @_;
954 # Failed login - Section 4.4.2
955 if (!ref(my $error = $session_or_error)) {
956 # Protocol can pass an error here to have XML generated or
959 my $packet = [[$NS_COMPONENT, 'presence'],
961 from
=> $self->{component_name
},
963 [error_tag
($error)]];
964 $self->xml_out($packet);
965 if ($error eq 'not_acceptable') {
967 $self->{authentication_errors
}->{$jid} = {
968 registration_info
=> $registration_info,
969 error_xml
=> $packet,
973 if ($USE_CONNECTION_MANAGER) {
974 Thrasher
::ConnectionManager
::connection_failure
(
975 $error_is_local_only,
982 delete $self->{authentication_errors
}->{$jid};
984 $self->send_presence_xml($full_jid, '');
986 my $session = $session_or_error;
987 # In case protocol didn't already associate the session.
988 $self->set_session_for($jid, $session);
989 $self->{protocol
}->initial_login($session);
990 if (defined($original_presence_tag)) {
991 # If this presence is intended for the transport, use it
992 # as the initial status for all transport contacts. Or, it
993 # may be targeted at a specific transport contact.
994 $self->echo_presence($session, $original_presence_tag);
997 if ($USE_CONNECTION_MANAGER) {
998 Thrasher
::ConnectionManager
::connection_success
();
1002 if (!defined($registration_info)) {
1003 # FIXME: Determine if this happens and when; be sure
1004 # to check the possibility of us losing the registration
1005 # info while the user still thinks they are registered.
1006 log "$jid sent us available presence but has no "
1011 # Verify that we have all required components
1012 my @required_items = $self->{protocol
}->registration_items;
1013 for my $item (@required_items) {
1014 if (!defined($registration_info->{$item})) {
1015 log("Registration item $item missing for $jid! Ack! Panic!");
1016 $self->{protocol
}->{backend
}->remove($jid);
1017 $self->xml_out([[$NS_COMPONENT, 'presence'],
1018 {from
=> $self->{component_name
},
1021 [error_tag
('registration_required')]]);
1026 my $protocol_login = sub {
1027 if ($self->session_for($jid)) {
1028 # Racing? Can't call ->login() with a session already defined.
1029 log("login($full_jid) reached protocol_login"
1030 . " but already has a session. WHAT IS GOING ON?\n");
1031 # Multiple active sessions for the same JID ends in tears.
1035 # If the connect was queued, a more current resource may have
1036 # been stored since this closure was created.
1037 my $last_full_jid = delete($self->{'connection_queued'}->{$jid})
1039 $self->{protocol
}->login($login_handler,
1044 $self->{'connection_queued'}->{$jid} = $full_jid;
1046 if (!$USE_CONNECTION_MANAGER) {
1047 $protocol_login->();
1049 my $immediate_connection = request_connect
($protocol_login);
1050 if (defined($WILL_BE_DIRECTLY_CONNECTED)) {
1051 $immediate_connection = $WILL_BE_DIRECTLY_CONNECTED;
1054 # In the event that an immediate connection is made, the rest
1055 # of the code already takes care of the presence tags.
1056 if (!$immediate_connection) {
1057 $self->send_connection_queued($jid);
1062 # Fires our extended "connection queued" presence tag at the given bare JID.
1063 sub send_connection_queued
{
1064 my ($self, $jid) = @_;
1066 my $thrasher_presence =
1067 [[[$NS_THRASHER_PRESENCE, 'connection-queued'], {}, []]];
1068 $self->send_presence_xml($jid,
1072 'connection queued',
1073 $thrasher_presence);
1078 my $session = shift;
1080 my $logout_status_message = shift;
1082 # Accept JIDs for the session
1083 if (!ref($session)) {
1084 $session = $self->session_for($session);
1087 if ($session->{status
} =~ /disconnecting/) {
1088 log("Already logging out $session->{jid}, but got another "
1089 ."request to log out.");
1093 log("Logging out $session->{jid}");
1095 $session->{status
} = 'disconnecting before presence';
1097 my $logout_handler = sub {
1098 # One way or another, logging off is successful.
1099 # Send logout packets; this should show everybody who
1100 # isn't offline as offline.
1102 if (!defined($session)) {
1103 # FIXME: This shouldn't happen.
1104 # Sequence to trigger:
1106 # * kill transport, whack database.
1107 # * come online still subscribed, go offline.
1108 # * this is reached.
1109 # As you can guess, the "whack database" step is frankly
1110 # more hostility than we can really plan for.
1112 confess
"Made it to logout handler without session.";
1115 $session->logout($self);
1117 my $roster = $self->{protocol
}->{backend
}->get_roster
1120 my @on_roster = map {
1121 $self->{protocol
}->{backend
}->legacy_name_to_jid($session->{jid
},
1123 $self->{component_name
})
1125 for my $roster_entry (@on_roster) {
1126 $self->send_presence_xml($session->{jid
}, 'unavailable',
1130 if ($extra && ref($extra) ne 'CODE') {
1131 log("Got 'extra' that isn't code: " . longmess
);
1136 $self->send_presence_xml($session->{jid
}, 'unavailable',
1137 undef, undef, $logout_status_message);
1139 $session->{status
} = 'disconnecting';
1141 delete $self->{sessions
}->{$session->{jid
}};
1143 log("session disconnected for $session->{jid}");
1146 # Do we also need to show all transport users as offline,
1147 # or does something in the server take care of that.
1148 $self->{protocol
}->logout($session, $logout_handler);
1151 sub handle_message
{
1155 my $body_xml = shift;
1157 my $chatstate = shift;
1159 if (defined($type) && $type eq 'error') {
1160 log("Got an error message from a user.");
1164 my $session = $self->session_for($from);
1166 # FIXME: There can be a race condition where the error sub is
1167 # called after the user disconnects. We shouldn't send this then.
1168 my $error_handler = sub {
1170 my $message = [[$NS_COMPONENT, 'message'],
1175 # $body_xml, # FIXME - better to send this?
1176 error_tag
($error)]];
1177 $self->xml_out($message);
1180 my $error_message = [[$NS_COMPONENT, 'message'],
1184 [error_tag
('registration_required'),
1187 my $registration_info = $self->registration_info($from);
1189 if (!defined($registration_info)) {
1190 $self->xml_out($error_message);
1194 # If we get here, the user has registered, and is sending
1195 # a message, but they are apparently not actually logged
1196 # in, perhaps because they deliberately logged off. I'm
1197 # choosing to allow them to log in this way.
1198 # FIXME: Hey, actually do that. For now you get an error.
1199 $self->send_error_message
1200 ($from, "You must be logged in to send messages "
1201 ."to the remote service users.", 'service_unavailable',
1205 } elsif (!$session->is_registered) {
1206 $self->xml_out($error_message);
1210 my $converted_to = $self->xmpp_name_to_legacy($session->{jid
},
1211 strip_resource
($to));
1213 # Tie successful call to the protocol to the successful extraction
1214 # of the message from the input
1217 my $body = extract
([undef, undef,
1218 save_sub
("text", \
&text_extractor
)],
1221 my $body_text = join '', @
{$body->{text
} || []};
1223 $self->{protocol
}->send_message($session,
1230 log("Error in extracting message from "
1231 . Dumper
($body_xml) . ":\n" . $@
);
1237 $self->{protocol
}->outgoing_chatstate($session,
1242 log("Error in outgoing_chatstate:\n$@");
1246 if (! ($body_xml || $chatstate)) {
1247 log('Message without usable child.');
1252 sub registration_info
{
1255 my $stripped_jid = strip_resource
($jid);
1256 return $self->{protocol
}->{backend
}->registered($stripped_jid);
1259 sub legacy_name_to_xmpp
{
1261 my $user_jid = strip_resource
(shift());
1262 my $legacy_name = shift;
1263 my $lang = shift || 'en';
1265 # FIXME: XMPP is correct
1266 # FIXME: Lang on the user
1267 return $self->{protocol
}->{backend
}->legacy_name_to_jid
1268 ($user_jid, $legacy_name, $self->{component_name
}, $lang);
1271 sub xmpp_name_to_legacy
{
1273 my $user_jid = strip_resource
(shift());
1274 my $target_jid = strip_resource
(shift());
1276 return $self->{protocol
}->{backend
}->jid_to_legacy_name
1277 ($user_jid, $target_jid);
1282 =head1 PROTOCOL INTERFACE
1284 The protocol interface is intended to sheild Thrasher::Protocol
1285 implementers from potential changes to the Component interface.
1286 If you, as a Thrasher::Protocol implementer ever feel compelled
1287 to reach into the ::Component to do anything not accessible from
1288 this interface, please let us know so we can give you a more
1291 The officially-implemented methods are:
1296 C<add_contact>($jid, $legacy_user_name): This will send out
1297 the correct <presence> tag to attempt to add the $legacy_user_name
1298 to the given $jid. This corresponds with section 5.1 in the XEP.
1300 You should be able to retrieve the $jid out of the information you
1301 stored in the ::Session, and you should send in the $legacy_user_name
1302 as the raw username from the service; ::Component will take care of
1303 mapping it as appropriate, in accordance with the name translation
1311 my $legacy_user_name = shift;
1313 my $legacy_jid = $self->legacy_name_to_xmpp
1314 ($jid, $legacy_user_name);
1316 $self->send_presence_xml($jid, 'subscribe', $legacy_jid);
1322 C<send_presence>($jid, $legacy_user_name, $type, $show):
1323 Send the given presence for the given legacy_user_name.
1324 The ::Protocol implementation will need to convert the status
1325 into an XMPP-status and give us the "type" and "show".
1332 my $legacy_user_name = shift;
1337 my $from_jid = $self->legacy_name_to_xmpp($jid, $legacy_user_name);
1340 $status = text
($status);
1343 my $session = $self->session_for($jid);
1344 $session->{component
}->{presence
}->{strip_resource
($jid)}->{strip_resource
($from_jid)} =
1345 [$type, $show, $status];
1347 $self->send_presence_xml($jid, $type, $from_jid, $show, $status);
1353 C<delete_contact>($jid, $legacy_user_name): This will send out
1354 the necessary packets to indicate that a user has unsubscribed.
1358 sub delete_contact
{
1361 my $legacy_user_name = shift;
1363 my $legacy_jid = $self->legacy_name_to_xmpp($jid, $legacy_user_name);
1365 $self->send_presence_xml($jid, 'unsubscribe', $legacy_jid);
1366 $self->send_presence_xml($jid, 'unsubscribed', $legacy_jid);
1367 # FIXME: Example 50 says this should be to the JID w/
1369 $self->send_presence_xml($jid, 'unavailable', $legacy_jid);
1375 C<send_message>($jid_from, $jid_to, $message, $extra): Sends a message
1376 from the given jid to the given jid. $extra is a hash containing extra
1377 parametrs, which include:
1383 C<$is_xhtml_ish>: If false, sends the UTF-8 encoded $message to the
1386 If it is true, it will process the XHTML-ish message into an
1387 XHTML and a plain text string, and send the XHTML-ish message
1388 as an XHTML-IM message in complaince with XEP-0071. Note that
1389 there is a normalization step, so you don't need to sweat
1390 whether it is proper XHTML; this does a decent job of turning
1395 C<$nick>: If set to a true string, will broadcast the nick conforming
1396 to XEP-0172. Note that according to the XEP, nickname should be
1397 broadcast only once per connection per (legacy) user, and it
1398 is your responsibility to ensure this, not this method's.
1402 C<$type>: If set, will set the type of the message to the given
1411 my $jid_from = shift;
1413 my $message = shift;
1416 my $type = $extra->{type
} || 'chat';
1417 my $is_xhtml_ish = $extra->{is_xhtml_ish
};
1418 my $nick = $extra->{nick
};
1419 my $extra_children = $extra->{children
} || [];
1422 $nick = [[[$NS_NICK, 'nick'], {}, [$nick]]];
1427 if ($jid_from =~ / / ||
1429 log("Trying to send/receive message from a JID with "
1430 ."a space in it: from: $jid_from to: $jid_to "
1435 if (!$is_xhtml_ish) {
1436 $self->xml_out([[$NS_COMPONENT, 'message'],
1440 [[[$NS_COMPONENT, 'body'],
1443 @
$nick, @
$extra_children]]);
1445 my ($xhtml, $text) = xhtml_and_text
($message);
1447 # Omit the XHTML-IM body if it turned out to be the same as
1450 if ($xhtml ne $text) {
1451 # XMPPStreamOut outputs a ref to a scalar as the scalar
1452 # without passing it through the normal escapeHTML() step.
1453 # The HTML $message may have &escape; sequences, which
1454 # xhtml_and_text passes through unaltered, so we need to
1455 # not re-escape even for the plain text body.
1456 @xhtml_part = [[$NS_XHTML_IM, 'html'],
1458 [[[$NS_XHTML, 'body'], {}, [\
$xhtml]]]]
1461 $self->xml_out([[$NS_COMPONENT, 'message'],
1465 [[[$NS_COMPONENT, 'body'],
1467 @
$nick, @
$extra_children,
1476 C<send_error_message>($jid, $error_msg): Sends an error message
1477 to the user, coming from the transport.
1479 In my experience, this should be limited, because this gets very
1480 annoying very quickly. As the method name implies, reserve it
1483 You're responsible for providing the errors. The $session for a user
1484 may have their language available to you in $session->get_lang,
1485 but it depends on their XMPP client (and how carefully we picked the
1486 language out of the stream).
1490 sub send_error_message
{
1492 my $target_jid = shift;
1493 my $error_message = shift;
1494 my $error_type = shift;
1495 my $from = shift || $self->{component_name
};
1497 my $error_body = [];
1500 push @
$error_body, error_tag
($error_type);
1503 $self->send_message($from, $target_jid,
1505 {type
=> 'error', children
=> $error_body});
1512 C<set_roster_name>($jid, $legacy_jid, $name): Sets $jid's
1513 roster entry to $legacy_jid to have the given nickname,
1514 if $jid's client advertises support for XEP-0144, by
1515 sending a modify request.
1519 sub set_roster_name
{
1522 my $legacy_jid = shift;
1526 my $session = $self->session_for($jid);
1529 my $iq = [[$NS_COMPONENT, 'iq'],
1530 {from
=> $self->{component_name
},
1533 [[[$NS_ROSTER_EXCHANGE, 'x'], {},
1534 [[[$NS_ROSTER_EXCHANGE, 'item'],
1535 {action
=> 'modify',
1539 $self->iq_query($iq);
1545 $session->do_if_feature($NS_ROSTER_EXCHANGE,
1556 # For some reason, we can no longer continue. Send all presence
1557 # closing, terminate the connection, and terminate the mainloop.
1562 $args{reason
} ||= 'Internal error';
1564 if ($self->{I_AM_TERMINATING
}) {
1568 log("Component terminating");
1569 $self->{I_AM_TERMINATING
} = 1;
1571 my $protocol = $self->{protocol
};
1572 my $sessions = $self->{sessions
};
1574 # If we are terminating because the DB lost the connection,
1575 # we no longer know enough to actually log people off. If
1576 # we are terminating due to a signal, or most other reasons,
1577 # we can log people off cleanly.
1578 if (!$args{no_db
}) {
1579 for my $session (values %$sessions) {
1580 log("Terminating connection for $session->{jid}");
1581 $self->logout($session, undef, $args{reason
});
1585 # And terminate the event loop, which is currently
1587 $self->{event_loop
}->quit;
1590 # This is for when the XMPP server stream simply disappears.
1591 # This is probably because the server has crashed or gone down.
1592 # In this case, we want the full terminate routine since it
1593 # probably implies all users have been disconnected.
1594 # Unfortunately, we can't know this, but it's the best guess.
1595 sub lost_connection
{
1601 # This is for when we have screwed up and borked our stream.
1602 # If this ever triggers, it is almost certainly a bug in
1603 # Thrasher, but let's at least try to recover. We may lose
1604 # some messages from the server in the meantime.
1605 # FIXME: We ought to have a configuration setting for whether
1606 # we try this recovery or just give up, because if you're
1607 # using component load balancing, this will really screw your
1609 sub reconnect_stream
{
1612 log("Attempting to reconnect stream.");
1614 # This causes any events that may be generated by the protocol
1615 # side while we are reconnecting to be buffered.
1616 $self->set_state('disconnected');
1618 # By the time this is getting called, the socket is entirely gone.
1619 log("Closing socket");
1620 $self->{thrasher_socket
}->close();
1623 eval { $self->{thrasher_socket
}->connect(); };
1625 # We can't seem to connect to the server. This should
1626 # never happen, so just panic.
1627 log("Connection to server could not be re-established.");
1632 log("Connection to server re-established. Handshaking.");
1634 $self->setup_streams;
1635 $self->{thrasher_socket
}->establish_fd_watch;
1637 # Re-begin connection process
1638 $self->output_initial_stream_tag;
1641 sub socket_in_closure
{
1648 my $val = eval { $socket->read(); };
1651 $self->lost_connection();
1654 elsif (! defined($val)) {
1661 $self->xml_in($val);
1664 # Terminate immediately after an unhandled error.
1665 # Ugly, but better than leaving protocol-side online
1666 # but component-side unreachable from the XMPP server
1667 # because only the FD watch has gone.
1668 log("Fatal error handling XML input:\n$@\n");
1675 log "Connection to XMPP server lost.";
1676 $self->lost_connection();
1685 sub compare_hashref
{
1689 if (scalar(keys %$a) != scalar(keys %$b)) {
1693 while (my ($key, $value) = each %$a) {
1694 if ($b->{$key} ne $value) {