Permalink
Browse files

- 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
  • Loading branch information...
1 parent 46252c3 commit 40e98b093fefa70d7983a5e09bc7cb147abae7b4 @yannk yannk committed with gbarr Jan 14, 2009
Showing with 175 additions and 7 deletions.
  1. +11 −7 lib/Authen/SASL/Perl/DIGEST_MD5.pm
  2. +30 −0 t/lib/common.pl
  3. +68 −0 t/negotiations/digest-md5.t
  4. +66 −0 t/negotiations/plain.t
@@ -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:
View
@@ -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;
@@ -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";
+ });
+}
View
@@ -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";
+ });
+}

0 comments on commit 40e98b0

Please sign in to comment.