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...
yannk authored and gbarr committed Jan 14, 2009
1 parent 46252c3 commit 40e98b093fefa70d7983a5e09bc7cb147abae7b4
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 # 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 @server_required = qw(algorithm nonce);
my @client_required = qw(username nonce cnonce nc qop response); 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; $self->{server_params} = \my %sparams;
# Parse response parameters # 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'"); or return $self->set_error("Bad challenge: '$challenge'");
if ($self->{state} == 1) { if ($self->{state} == 1) {
@@ -384,7 +386,7 @@ sub server_step {
my $challenge = shift; my $challenge = shift;
$self->{client_params} = \my %cparams; $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'"); or return $self->set_error("Bad challenge: '$challenge'");
# check required fields in server challenge # check required fields in server challenge
@@ -453,6 +455,7 @@ sub _response {
sub _parse_challenge { sub _parse_challenge {
my $self = shift; my $self = shift;
my $challenge_ref = shift; my $challenge_ref = shift;
my $type = shift;
my $params = shift; my $params = shift;
while($$challenge_ref =~ while($$challenge_ref =~
@@ -467,7 +470,7 @@ sub _parse_challenge {
if ($v =~ /^"(.*)"$/s) { if ($v =~ /^"(.*)"$/s) {
($v = $1) =~ s/\\(.)/$1/g; ($v = $1) =~ s/\\(.)/$1/g;
} }
if (exists $multi{$k}) { if (exists $multi{$type}{$k}) {
my $aref = $params->{$k} ||= []; my $aref = $params->{$k} ||= [];
push @$aref, $v; push @$aref, $v;
} }
@@ -724,15 +727,16 @@ The callbacks used are:
=item authname =item authname
The authorization id to use after successful authentication The authorization id to use after successful authentication (client)
=item user =item user
The username to be used in the response The username to be used in the response (client)
=item pass =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 If this callback is a coderef, then in server_step, the following
arguments are passed: 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.