Changeset 849

Timestamp:

02/11/09 21:57:01 (10 months ago)

Author:

ykerherve

Message:

Fixed issues detected with Mike Malone and Mart Atkins today
(Section 8.3 of RFC 3920: If resource is not specified by
the client, the server should generate a random one)

Location:

trunk/DJabberd

Files:

• lib/DJabberd/IQ.pm (modified) (2 diffs)
• t/lib/djabberd-test.pl (modified) (2 diffs)
• t/sasl-login.t (modified) (7 diffs)

trunk/DJabberd/lib/DJabberd/IQ.pm

@@ -4 +4 @@
 use DJabberd::Util qw(exml);
 use DJabberd::Roster;
+use Digest::SHA1;
 
 use DJabberd::Log;
@@ -626 +627 @@
     };
 
-    my $resource = $get->("resource") || "";
+    my $resource = $get->("resource")
+                 || Digest::SHA1::sha1_hex(rand() . rand() . rand());
 
     my $vhost = $conn->vhost;

trunk/DJabberd/t/lib/djabberd-test.pl

@@ -566 +566 @@
     my $self = shift;
     my $sasl = shift;
+    my $res  = shift;
     my $sec  = shift;
 
@@ -623 +624 @@
     die "no session"  unless $features =~ /session\b/sm;
 
-    $self->bind_resource;
-    return 1;
+    return $self->bind_resource($res);
 }
 
 sub bind_resource {
     my $self = shift;
+    my $res  = shift;
     my $sock = $self->{sock};
 
     print $sock <<EOB;
-<iq type='set' id='purple81e4b57b'><bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'><resource>yann</resource></bind></iq>
+<iq type='set' id='purple81e4b57b'><bind xmlns='urn:ietf:params:xml:ns:xmpp-bind'><resource>$res</resource></bind></iq>
 EOB
     my $iq = $self->recv_xml_obj;
     die "invalid bind response" unless $iq->element_name eq 'iq';
     my $bind = $iq->first_element;
-    die "invalid bind response" unless $bind->element_name eq 'bind';
+    die "invalid bind response " unless $bind->element_name eq 'bind';
     my $jid_el = $bind  ->first_element or die "no jid elt...";
     my $jid    = $jid_el->first_child   or die "no jid...";
+    return $jid;
 }
 

trunk/DJabberd/t/sasl-login.t

@@ -2 +2 @@
 use strict;
 use warnings;
-use Test::More tests => 26;
+use Test::More tests => 46;
 use lib 't/lib';
 
@@ -10 +10 @@
 
 my $login_and_be = sub {
-    my ($pa, $pb, $sasl) = @_;
+    my ($pa, $pb, $sasl, $res) = @_;
 
-    $pa->sasl_login($sasl);
+    my $jid = $pa->sasl_login($sasl, $res);
     $pb->login;
     $pa->send_xml("<presence/>");
@@ -21 +21 @@
     $pb->send_xml("<iq type='get' id='pb1' to='$pa'><x/></iq>");
     like($pa->recv_xml, qr/id=.pb./, "pb got pa's iq");
+    return $jid;
 };
 
@@ -37 +38 @@
             );
 
-            $login_and_be->($pa, $pb, $sasl);
+            my $jid = $login_and_be->($pa, $pb, $sasl, "yann");
+            like $jid, qr/yann/, "resource assigned accordingly";
         });
     }
+}
+
+## resource not provided by the client 
+{
+    two_parties(sub {
+        my ($pa, $pb) = @_;
+
+        my $sasl = Authen::SASL->new(
+            mechanism => "DIGEST-MD5",
+            callback  => {
+                pass => sub { $pa->password },
+                user => sub { $pa->{name}   },
+            },
+        );
+
+        my $jid = $login_and_be->($pa, $pb, $sasl, undef); # << no resource
+        ok $jid, "got jid";
+        like $jid, qr{/\w+$}, "assigned resource $jid";
+    });
+}
+
+## resource conflict, resource reassigned
+{
+    two_parties(sub {
+        my ($pa, $pb) = @_;
+
+        my $sasl = Authen::SASL->new(
+            mechanism => "DIGEST-MD5",
+            callback  => {
+                pass => sub { $pa->password },
+                user => sub { $pa->{name}   },
+            },
+        );
+        my $pa_jid = $pa->sasl_login($sasl, "yann");
+        my $pb_jid = $pb->sasl_login($sasl, "yann");
+        my ($pa_res) = $pa_jid =~ m{/(\w+)$};
+        my ($pb_res) = $pb_jid =~ m{/(\w+)$};
+        cmp_ok $pa_res, 'ne', $pb_res, "resources are different";
+        is   $pa_res, "yann", "first got what it wanted";
+        isnt $pb_res, "yann", "second didn't";
+    });
 }
 
@@ -58 +101 @@
 
         my $pa = Test::DJabberd::Client->new(server => $server, name => "partya");
-        eval { $pa->sasl_login($sasl) };
+        eval { $pa->sasl_login($sasl, "yann") };
         my $err = $@;
         ok $err, "login failure";
@@ -76 +119 @@
 
     my $pa = Test::DJabberd::Client->new(server => $server, name => "partya");
-    my $response = $pa->abort_sasl_login($sasl);
+    my $response = $pa->abort_sasl_login($sasl, "yann");
     like $response, qr{failure.*<aborted/>};
 }
@@ -100 +143 @@
 
     my $pa = Test::DJabberd::Client->new(server => $strong_server, name => "partya");
-    eval { $pa->sasl_login($sasl) };
+    eval { $pa->sasl_login($sasl, "yann") };
     my $err = $@;
     like $err, qr{failure.*<invalid-mechanism/>};