Treat the node and domain parts of a JID as case-insensitive as per t…

…he XMPP spec.

This creates a dependency on the CPAN module Unicode::Stringprep. A backward-compatibility setting is provided for servers that have existing non-normalized JIDs stored, since they are likely to be broken by this change until their stored data is normalized.

CHANGES

@@ -1,3 +1,11 @@
+  - Treat the node and domain parts of a JID as case-insensitive as per
+    the XMPP spec. This creates a dependency on the CPAN module
+    Unicode::Stringprep. A backward-compatibility setting is provided
+    for servers that have existing non-normalized JIDs stored,
+    since they are likely to be broken by this change until their
+    stored data is normalized.
+    Patch from Alex Vandiver <alexmv@bestpractical.com>
+
   - Some configuration file docs
     (Alex Vandiver <alexmv@bestpractical.com>)
 

MANIFEST

@@ -155,3 +155,4 @@ t/unsubscribe.t
 t/versions.t
 t/write-error-and-close.t
 t/xmlparsing.t
+t/jidcase.t

Makefile.PL

@@ -14,6 +14,7 @@ WriteMakefile(
                   'Net::SSLeay'                  => 0,
                   'Log::Log4perl'                => 0,
                   'Digest::HMAC_SHA1'            => 0,
+                  'Unicode::Stringprep'          => 0,
               },
               clean      => { FILES => 't/log/*' },
               AUTHOR     => 'Brad Fitzpatrick <brad@danga.com>',

lib/DJabberd.pm

@@ -167,6 +167,11 @@ sub fake_s2s_peer {
     return $fake_peers{$host};
 }
 
+sub set_config_casesensitive {
+    my ($self, $val) = @_;
+    $DJabberd::JID::CASE_SENSITIVE = as_bool($val);
+}
+
 sub add_vhost {
     my ($self, $vhost) = @_;
     my $sname = lc $vhost->name;

lib/DJabberd/Connection/ServerIn.pm

@@ -16,7 +16,7 @@ sub set_vhost {
 
 sub peer_domain_is_verified {
     my ($self, $domain) = @_;
-    return $self->{verified_remote_domain}->{$domain};
+    return $self->{verified_remote_domain}->{lc $domain};
 }
 
 sub on_stream_start {
@@ -140,7 +140,7 @@ sub dialback_result_valid {
     my %opts = @_;
 
     my $res = qq{<db:result from='$opts{recv_server}' to='$opts{orig_server}' type='valid'/>};
-    $self->{verified_remote_domain}->{$opts{orig_server}} = $opts{orig_server};
+    $self->{verified_remote_domain}->{lc $opts{orig_server}} = $opts{orig_server};
     $self->log->debug("Dialback result valid for connection $self->{id}.  from=$opts{recv_server}, to=$opts{orig_server}: $res\n");
     $self->write($res);
 }

lib/DJabberd/JID.pm

@@ -3,6 +3,9 @@ use strict;
 use DJabberd::Util qw(exml);
 use Digest::SHA1;
 
+# Configurable via 'CaseSensitive' config option
+our $CASE_SENSITIVE = 0;
+
 use overload
     '""' => \&as_string_exml;
 
@@ -13,6 +16,84 @@ use constant AS_STRING  => 3;
 use constant AS_BSTRING => 4;
 use constant AS_STREXML => 5;
 
+# Stringprep functions for converting to canonical form
+use Unicode::Stringprep;
+use Unicode::Stringprep::Mapping;
+use Unicode::Stringprep::Prohibited;
+my $nodeprep = Unicode::Stringprep->new(
+    3.2,
+    [
+        \@Unicode::Stringprep::Mapping::B1,
+        \@Unicode::Stringprep::Mapping::B2,
+    ],
+    'KC',
+    [
+        \@Unicode::Stringprep::Prohibited::C11,
+        \@Unicode::Stringprep::Prohibited::C12,
+        \@Unicode::Stringprep::Prohibited::C21,
+        \@Unicode::Stringprep::Prohibited::C22,
+        \@Unicode::Stringprep::Prohibited::C3,
+        \@Unicode::Stringprep::Prohibited::C4,
+        \@Unicode::Stringprep::Prohibited::C5,
+        \@Unicode::Stringprep::Prohibited::C6,
+        \@Unicode::Stringprep::Prohibited::C7,
+        \@Unicode::Stringprep::Prohibited::C8,
+        \@Unicode::Stringprep::Prohibited::C9,
+        [
+            0x0022, undef, # "
+            0x0026, undef, # &
+            0x0027, undef, # '
+            0x002F, undef, # /
+            0x003A, undef, # :
+            0x003C, undef, # <
+            0x003E, undef, # >
+            0x0040, undef, # @
+        ]
+    ],
+    1,
+);
+my $nameprep = Unicode::Stringprep->new(
+    3.2,
+    [
+        \@Unicode::Stringprep::Mapping::B1,
+        \@Unicode::Stringprep::Mapping::B2,
+    ],
+    'KC',
+    [
+        \@Unicode::Stringprep::Prohibited::C12,
+        \@Unicode::Stringprep::Prohibited::C22,
+        \@Unicode::Stringprep::Prohibited::C3,
+        \@Unicode::Stringprep::Prohibited::C4,
+        \@Unicode::Stringprep::Prohibited::C5,
+        \@Unicode::Stringprep::Prohibited::C6,
+        \@Unicode::Stringprep::Prohibited::C7,
+        \@Unicode::Stringprep::Prohibited::C8,
+        \@Unicode::Stringprep::Prohibited::C9,
+    ],
+    1,
+);
+my $resourceprep = Unicode::Stringprep->new(
+    3.2,
+    [
+        \@Unicode::Stringprep::Mapping::B1,
+    ],
+    'KC',
+    [
+        \@Unicode::Stringprep::Prohibited::C12,
+        \@Unicode::Stringprep::Prohibited::C21,
+        \@Unicode::Stringprep::Prohibited::C22,
+        \@Unicode::Stringprep::Prohibited::C3,
+        \@Unicode::Stringprep::Prohibited::C4,
+        \@Unicode::Stringprep::Prohibited::C5,
+        \@Unicode::Stringprep::Prohibited::C6,
+        \@Unicode::Stringprep::Prohibited::C7,
+        \@Unicode::Stringprep::Prohibited::C8,
+        \@Unicode::Stringprep::Prohibited::C9,
+    ],
+    1,
+);
+
+
 # returns DJabberd::JID object, or undef on failure due to invalid format
 sub new {
     #my ($class, $jidstring) = @_;
@@ -29,7 +110,20 @@ sub new {
            (?: /(.{1,1023})   )?                                           # $3: optional resource
            $!x;
 
-    return bless [ $1, $2, $3 ], $_[0];
+    # If we're in case-sensitive mode, for backwards-compatibility,
+    # then skip stringprep
+    return bless [ $1, $2, $3 ], $_[0] if $DJabberd::JID::CASE_SENSITIVE;
+
+    # Stringprep uses regexes, so store these away first
+    my ($node, $host, $res) = ($1, $2, $3);
+
+    return eval {
+        bless [
+            defined $node ? $nodeprep->($node) : undef,
+            $nameprep->($host),
+            defined $res  ? $resourceprep->($res) : undef,
+        ], $_[0]
+    };
 }
 
 sub is_bare {