- Added new tests using complete negotiations using one Authen::SASL

  client and one Authen::SASL server
- Fixed realm challenge parsing when the challenge originates from
  the client. In this case it shouldn't be a multivalued token

lib/Authen/SASL/Perl/DIGEST_MD5.pm

@@ -37,7 +37,9 @@ my (%cqdval, %sqdval);
 #  username authzid realm nonce cnonce digest-uri qop cipher
 #)} = ();
 
-my %multi; @multi{qw(realm auth-param)} = ();
+my %multi;
+@{$multi{server}}{qw(realm auth-param)} = ();
+@{$multi{client}}{qw()} = ();
 
 my @server_required = qw(algorithm nonce);
 my @client_required = qw(username nonce cnonce nc qop response);
@@ -232,7 +234,7 @@ sub client_step {   # $self, $server_sasl_credentials
   $self->{server_params} = \my %sparams;
 
   # Parse response parameters
-  $self->_parse_challenge(\$challenge, $self->{server_params})
+  $self->_parse_challenge(\$challenge, server => $self->{server_params})
     or return $self->set_error("Bad challenge: '$challenge'");
 
   if ($self->{state} == 1) {
@@ -384,7 +386,7 @@ sub server_step {
   my $challenge = shift;
 
   $self->{client_params} = \my %cparams;
-  $self->_parse_challenge(\$challenge, $self->{client_params})
+  $self->_parse_challenge(\$challenge, client => $self->{client_params})
      or return $self->set_error("Bad challenge: '$challenge'");
 
   # check required fields in server challenge
@@ -453,6 +455,7 @@ sub _response {
 sub _parse_challenge {
   my $self          = shift;
   my $challenge_ref = shift;
+  my $type          = shift;
   my $params        = shift;
 
   while($$challenge_ref =~
@@ -467,7 +470,7 @@ sub _parse_challenge {
     if ($v =~ /^"(.*)"$/s) {
       ($v = $1) =~ s/\\(.)/$1/g;
     }
-    if (exists $multi{$k}) {
+    if (exists $multi{$type}{$k}) {
       my $aref = $params->{$k} ||= [];
       push @$aref, $v;
     }
@@ -724,15 +727,16 @@ The callbacks used are:
 
 =item authname
 
-The authorization id to use after successful authentication
+The authorization id to use after successful authentication (client)
 
 =item user
 
-The username to be used in the response
+The username to be used in the response (client)
 
 =item pass
 
-The password to be used to compute the response
+The password to be used to compute the response.
+
 If this callback is a coderef, then in server_step, the following
 arguments are passed:
 

t/lib/common.pl

@@ -0,0 +1,30 @@
+use strict;
+use warnings;
+
+use Authen::SASL ('Perl');
+
+sub negotiate {
+    my ($c, $s, $do) = @_;
+
+    my $client_sasl = Authen::SASL->new( %{ $c->{sasl} } );
+    my $server_sasl = Authen::SASL->new( %{ $s->{sasl} } );
+
+    my $client = $client_sasl->client_new(@$c{qw/service host security/});
+    my $server = $server_sasl->server_new(@$s{qw/service host/});
+
+    my $start     = $client->client_start();
+    my $challenge = $server->server_start($start);
+
+    my $response;
+    while ($client->need_step || $server->need_step) {
+        $response = $client->client_step($challenge)
+            if $client->need_step;
+        last if $client->error;
+        $challenge = $server->server_step($response)
+            if $server->need_step;
+        last if $server->error;
+    }
+    $do->($client, $server);
+}
+
+1;

t/negotiations/digest-md5.t

@@ -0,0 +1,68 @@
+#!perl
+use strict;
+use warnings;
+use Test::More tests => 4;
+use FindBin qw($Bin);
+require "$Bin/../lib/common.pl";
+
+## base conf
+my $cconf = {
+    sasl => {
+        mechanism => 'DIGEST-MD5',
+        callback => {
+            user => 'yann',
+            pass => 'maelys',
+        },
+    },
+    host => 'localhost',
+    security => 'noanonymous',
+    service => 'xmpp',
+};
+
+my $sconf = {
+    sasl => {
+        mechanism => 'DIGEST-MD5',
+        callback => {
+            pass => 'maelys',
+        },
+    },
+    host => 'localhost',
+    service => 'xmpp',
+};
+
+## base negotiation should work
+negotiate($cconf, $sconf, sub {
+    my ($clt, $srv) = @_;
+    ok $clt->is_success, "client success" or diag $clt->error;
+    ok $srv->is_success, "server success" or diag $srv->error;
+});
+
+## invalid password
+{
+    local $cconf->{sasl}{callback}{pass} = "YANN";
+
+    negotiate($cconf, $sconf, sub {
+        my ($clt, $srv) = @_;
+        ok !$srv->is_success, "failure";
+        like $srv->error, qr/response/;
+    });
+}
+
+## arguments passed to server pass callback
+{
+    local $cconf->{sasl}{callback}{authname} = "some authzid";
+    local $sconf->{sasl}{callback}{pass} = sub {
+        my $server = shift;
+        my ($username, $realm, $authzid) = @_;
+        is $username, "yann",         "username";
+        is $realm,    "localhost",    "realm";
+        is $authzid,  "some authzid", "authzid";
+        return "incorrect";
+    };
+
+    negotiate($cconf, $sconf, sub {
+        my ($clt, $srv) = @_;
+        ok !$srv->is_success, "failure";
+        like $srv->error, qr/response/, "incorrect response";
+    });
+}

t/negotiations/plain.t

@@ -0,0 +1,66 @@
+#!perl
+
+use Test::More tests => 14;
+
+use FindBin qw($Bin);
+require "$Bin/../lib/common.pl";
+
+use Authen::SASL qw(Perl);
+use_ok('Authen::SASL::Perl::PLAIN');
+
+## base conf
+my $cconf = {
+    sasl => {
+        mechanism => 'PLAIN',
+        callback => {
+            user => 'yann',
+            pass => 'maelys',
+        },
+    },
+    host => 'localhost',
+    service => 'xmpp',
+};
+
+my $sconf = {
+    sasl => {
+        mechanism => 'PLAIN',
+        callback => {
+            pass => 'maelys',
+        },
+    },
+    host => 'localhost',
+    service => 'xmpp',
+};
+
+## base negotiation should work
+negotiate($cconf, $sconf, sub {
+    my ($clt, $srv) = @_;
+    is $clt->mechanism, "PLAIN";
+    is $srv->mechanism, "PLAIN";
+    ok $clt->is_success, "client success" or diag $clt->error;
+    ok $srv->is_success, "server success" or diag $srv->error;
+});
+
+## invalid password
+{
+    # hey callback could just be a subref that returns a localvar
+    local $sconf->{sasl}{callback}{pass} = "x";
+
+    negotiate($cconf, $sconf, sub {
+        my ($clt, $srv) = @_;
+        ok ! $srv->is_success, "wrong pass";
+        like $srv->error, qr/match/, "error set";
+    });
+}
+
+## invalid password
+{
+    # hey callback could just be a subref that returns a localvar
+    local $sconf->{sasl}{callback}{pass} = "x";
+
+    negotiate($cconf, $sconf, sub {
+        my ($clt, $srv) = @_;
+        ok ! $srv->is_success, "wrong pass";
+        like $srv->error, qr/match/, "error set";
+    });
+}