Skip to content
Browse files

Transformed server_start and server_step to use callbacks

allowing me to execute SASL negotiations fully asynchronously within
djabberd.

Tests are still expecting a linear run
  • Loading branch information...
1 parent 339f43b commit 44a633e733560ed4d32de943acdf7c044c45a542 @yannk yannk committed with gbarr Mar 4, 2009
View
100 lib/Authen/SASL/Perl/DIGEST_MD5.pm
@@ -197,6 +197,7 @@ sub client_start {
sub server_start {
my $self = shift;
my $challenge = shift;
+ my $cb = shift || sub {};
$self->{need_step} = 1;
$self->{error} = undef;
@@ -227,8 +228,9 @@ sub server_start {
'qop' => $qop,
'cipher' => [ map { $_->{name} } @ourciphers ],
);
-
- return _response(\%response);
+ my $final_response = _response(\%response);
+ $cb->($final_response);
+ return;
}
sub client_step { # $self, $server_sasl_credentials
@@ -386,30 +388,42 @@ sub _compute_digests_and_set_keys {
sub server_step {
my $self = shift;
my $challenge = shift;
+ my $cb = shift || sub {};
$self->{client_params} = \my %cparams;
- $self->_parse_challenge(\$challenge, client => $self->{client_params})
- or return $self->set_error("Bad challenge: '$challenge'");
+ unless ( $self->_parse_challenge(\$challenge, client => $self->{client_params}) ) {
+ $self->set_error("Bad challenge: '$challenge'");
+ return $cb->();
+ }
# check required fields in server challenge
if (my @missing = grep { !exists $cparams{$_} } @client_required) {
- return $self->set_error("Client did not provide required field(s): @missing")
+ $self->set_error("Client did not provide required field(s): @missing");
+ return $cb->();
}
my $count = hex ($cparams{'nc'} || 0);
- return $self->set_error("nonce-count doesn't match: $count")
- unless $count == ++$self->{nonce_counts}{$cparams{nonce}};
+ unless ($count == ++$self->{nonce_counts}{$cparams{nonce}}) {
+ $self->set_error("nonce-count doesn't match: $count");
+ return $cb->();
+ }
my $qop = $cparams{'qop'} || "auth";
- return $self->set_error("Client qop not supported (qop = '$qop')")
- unless $self->is_qop_supported($qop);
+ unless ($self->is_qop_supported($qop)) {
+ $self->set_error("Client qop not supported (qop = '$qop')");
+ return $cb->();
+ }
- my $username = $cparams{'username'}
- or return $self->set_error("Client didn't provide a username");
+ my $username = $cparams{'username'};
+ unless ($username) {
+ $self->set_error("Client didn't provide a username");
+ return $cb->();
+ }
# "The authzid MUST NOT be an empty string."
if (exists $cparams{authzid} && $cparams{authzid} eq '') {
- return $self->set_error("authzid cannot be empty");
+ $self->set_error("authzid cannot be empty");
+ return $cb->();
}
my $authzid = $cparams{authzid};
@@ -419,34 +433,49 @@ sub server_step {
my $digest_uri = $cparams{'digest-uri'};
my ($cservice, $chost, $cservname) = split '/', $digest_uri, 3;
if ($cservice ne $self->service or $chost ne $self->host) {
- # XXX deal with serv_name
- return $self->set_error("Incorrect digest-uri");
+ # XXX deal with serv_name
+ $self->set_error("Incorrect digest-uri");
+ return $cb->();
}
- my $realm = $cparams{'realm'};
- my $password = $self->_call('getsecret', $username, $realm, $authzid );
- return $self->set_error("Cannot get the passord for $username")
- unless defined $password;
-
- ## configure the security layer
- $self->_server_layer($qop)
- or return $self->set_error("Cannot negociate the security layer");
-
- my ($expected, $rspauth)
- = $self->_compute_digests_and_set_keys($password, $self->{client_params});
+ unless (defined $self->callback('getsecret')) {
+ $self->set_error("a getsecret callback MUST be defined");
+ $cb->();
+ return;
+ }
- return $self->set_error("Incorrect response $cparams{response} <> $expected")
- unless $expected eq $cparams{response};
+ my $realm = $self->{client_params}->{'realm'};
+ my $response_check = sub {
+ my $password = shift;
+ return $self->set_error("Cannot get the passord for $username")
+ unless defined $password;
+
+ ## configure the security layer
+ $self->_server_layer($qop)
+ or return $self->set_error("Cannot negociate the security layer");
+
+ my ($expected, $rspauth)
+ = $self->_compute_digests_and_set_keys($password, $self->{client_params});
+
+ return $self->set_error("Incorrect response $self->{client_params}->{response} <> $expected")
+ unless $expected eq $self->{client_params}->{response};
+
+ my %response = (
+ rspauth => $rspauth,
+ );
+
+ # I'm not entirely sure of what I am doing
+ $self->{answer}{$_} = $self->{client_params}->{$_} for qw/username authzid realm serv/;
+
+ $self->set_success;
+ return _response(\%response);
+ };
- my %response = (
- rspauth => $rspauth,
+ $self->callback('getsecret')->(
+ $self,
+ { user => $username, realm => $realm, authzid => $authzid },
+ sub { $cb->( $response_check->( shift ) ) },
);
-
- # I'm not entirely sure of what I am doing
- $self->{answer}{$_} = $cparams{$_} for qw/username authzid realm serv/;
-
- $self->set_success;
- return _response(\%response);
}
sub is_qop_supported {
@@ -606,7 +635,6 @@ sub _client_layer {
sub _select_cipher {
my ($self, $minssf, $maxssf, $ciphers) = @_;
- $DB::single=1;
# compose a subset of candidate ciphers based on ssf and peer list
my @a = map {
View
74 lib/Authen/SASL/Perl/LOGIN.pm
@@ -54,53 +54,77 @@ sub client_step {
sub server_start {
my $self = shift;
my $response = shift;
+ my $user_cb = shift || sub {};
$self->{answer} = {};
$self->{stage} = 0;
$self->{need_step} = 1;
$self->{error} = undef;
- return 'Username:';
+ $user_cb->('Username:');
+ return;
}
sub server_step {
my $self = shift;
my $response = shift;
+ my $user_cb = shift || sub {};
my $stage = ++$self->{stage};
if ($stage == 1) {
- return $self->set_error("Invalid sequence (empty username)")
- unless defined $response;
+ unless (defined $response) {
+ $self->set_error("Invalid sequence (empty username)");
+ return $user_cb->();
+ }
$self->{answer}{user} = $response;
- return "Password:";
+ return $user_cb->("Password:");
}
elsif ($stage == 2) {
- return $self->set_error("Invalid sequence (empty pass)")
- unless defined $response;
+ unless (defined $response) {
+ $self->set_error("Invalid sequence (empty pass)");
+ return $user_cb->();
+ }
$self->{answer}{pass} = $response;
}
else {
- return $self->set_error("Invalid sequence (end)");
+ $self->set_error("Invalid sequence (end)");
+ return $user_cb->();
}
-
- if ($self->callback('checkpass')) {
- my @answers = ($self->{answer}{user}, $self->{answer}{pass});
- if ($self->_call('checkpass', @answers) ) {
- $self->set_success;
- return 1;
- }
- else {
- return $self->set_error("Credentials don't match");
- }
+ my $error = "Credentials don't match";
+ my $answers = { user => $self->{answer}{user}, pass => $self->{answer}{pass} };
+ if (my $checkpass = $self->{callback}{checkpass}) {
+ my $cb = sub {
+ my $result = shift;
+ unless ($result) {
+ $self->set_error($error);
+ $user_cb->();
+ }
+ else {
+ $self->set_success;
+ }
+ };
+ $checkpass->($self => $answers => $cb );
+ return;
+ }
+ elsif (my $getsecret = $self->{callback}{getsecret}) {
+ my $cb = sub {
+ my $good_pass = shift;
+ if ($good_pass && $good_pass eq ($self->{answer}{pass} || "")) {
+ $self->set_success;
+ }
+ else {
+ $self->set_error($error);
+ }
+ $user_cb->();
+ };
+ $getsecret->($self => $answers => $cb );
+ return;
+ }
+ else {
+ $self->set_error($error);
+ $user_cb->();
}
- my $expected_pass = $self->_call('getsecret', $self->{answer}{user});
- return $self->set_error("Credentials don't match, (expected)")
- unless defined $expected_pass;
- return $self->set_error("Credentials don't match")
- unless $expected_pass eq ($self->{answer}{pass} || "");
-
- $self->set_success;
- return 1;
+ return;
}
1;
View
59 lib/Authen/SASL/Perl/PLAIN.pm
@@ -41,6 +41,7 @@ sub client_start {
sub server_start {
my $self = shift;
my $response = shift;
+ my $user_cb = shift || sub {};
$self->{error} = undef;
return $self->set_error("No response: Credentials don't match")
@@ -49,26 +50,48 @@ sub server_start {
my %parts;
@parts{@tokens} = split "\0", $response, scalar @tokens;
+
# I'm not entirely sure of what I am doing
$self->{answer}{$_} = $parts{$_} for qw/authname user/;
+ my $error = "Credentials don't match";
+
+ ## checkpass
+ if (my $checkpass = $self->callback('checkpass')) {
+ my $cb = sub {
+ my $result = shift;
+ unless ($result) {
+ $self->set_error($error);
+ $user_cb->();
+ }
+ else {
+ $self->set_success;
+ }
+ };
+ $checkpass->($self => { %parts } => $cb );
+ return;
+ }
+
+ ## getsecret
+ elsif (my $getsecret = $self->callback('getsecret')) {
+ my $cb = sub {
+ my $good_pass = shift;
+ if ($good_pass && $good_pass eq ($parts{pass} || "")) {
+ $self->set_success;
+ }
+ else {
+ $self->set_error($error);
+ }
+ $user_cb->();
+ };
+ $getsecret->( $self, { map { $_ => $parts{$_ } } qw/user authname/ }, $cb );
+ return;
+ }
- if (defined $self->callback('checkpass')) {
- if ($self->_call('checkpass', @parts{qw/user pass authname/}) ) {
- $self->set_success;
- return;
- }
- else {
- return $self->set_error("Credentials don't match");
- }
+ ## error by default
+ else {
+ $self->set_error($error);
+ $user_cb->();
}
- my $expected_pass = $self->_call('getsecret', @parts{qw/user authname/});
- return $self->set_error("Credentials don't match")
- unless defined $expected_pass;
- return $self->set_error("Credentials don't match")
- unless $expected_pass eq ($parts{pass} || "");
-
- $self->set_success;
- return;
}
1;
@@ -122,10 +145,6 @@ The user's password to be used for authentication.
=over4
-=item getsecret(username, realm)
-
-returns the password associated with C<username> and C<realm>
-
=item checkpass(username, password, realm)
returns true and false depending on the validity of the credentials passed
View
8 t/lib/common.pl
@@ -13,14 +13,18 @@ sub negotiate {
my $server = $server_sasl->server_new(@$s{qw/service host/});
my $start = $client->client_start();
- my $challenge = $server->server_start($start);
+
+ my $challenge;
+ my $next_cb = sub { $challenge = shift };
+ $server->server_start($start, $next_cb);
my $response;
+ ## note: this wouldn't work in a real async environment
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)
+ $server->server_step($response, $next_cb)
if $server->need_step;
last if $server->error;
}
View
12 t/negotiations/digest_md5.t
@@ -23,7 +23,7 @@ my $sconf = {
sasl => {
mechanism => 'DIGEST-MD5',
callback => {
- getsecret => 'maelys',
+ getsecret => sub { $_[2]->('maelys') },
},
},
host => 'localhost',
@@ -53,11 +53,11 @@ negotiate($cconf, $sconf, sub {
local $cconf->{sasl}{callback}{authname} = "some authzid";
local $sconf->{sasl}{callback}{getsecret} = sub {
my $server = shift;
- my ($username, $realm, $authzid) = @_;
- is $username, "yann", "username";
- is $realm, "localhost", "realm";
- is $authzid, "some authzid", "authzid";
- return "incorrect";
+ my ($args, $cb) = @_;
+ is $args->{user}, "yann", "username";
+ is $args->{realm}, "localhost", "realm";
+ is $args->{authzid}, "some authzid", "authzid";
+ $cb->("incorrect");
};
negotiate($cconf, $sconf, sub {
View
14 t/negotiations/login.t
@@ -6,7 +6,7 @@ use FindBin qw($Bin);
require "$Bin/../lib/common.pl";
use Authen::SASL qw(Perl);
-use_ok('Authen::SASL::Perl::PLAIN');
+use_ok('Authen::SASL::Perl::LOGIN');
## base conf
my $cconf = {
@@ -20,20 +20,19 @@ my $cconf = {
host => 'localhost',
service => 'xmpp',
};
-
+my $Password = 'maelys';
my $sconf = {
sasl => {
mechanism => 'LOGIN',
callback => {
- getsecret => 'maelys',
+ getsecret => sub { $_[2]->($Password) },
},
},
host => 'localhost',
service => 'xmpp',
};
## base negotiation should work
-$DB::single=1;
negotiate($cconf, $sconf, sub {
my ($clt, $srv) = @_;
is $clt->mechanism, "LOGIN";
@@ -45,7 +44,7 @@ negotiate($cconf, $sconf, sub {
## invalid password
{
# hey callback could just be a subref that returns a localvar
- local $sconf->{sasl}{callback}{getsecret} = "wrong";
+ $Password = "wrong";
negotiate($cconf, $sconf, sub {
my ($clt, $srv) = @_;
@@ -54,10 +53,9 @@ negotiate($cconf, $sconf, sub {
});
}
-## invalid password
+## invalid password with different callback
{
- # hey callback could just be a subref that returns a localvar
- local $sconf->{sasl}{callback}{checkpass} = sub { 0 };
+ local $sconf->{sasl}{callback}{checkpass} = sub { $_[2]->(0) };
negotiate($cconf, $sconf, sub {
my ($clt, $srv) = @_;
View
8 t/negotiations/plain.t
@@ -21,11 +21,12 @@ my $cconf = {
service => 'xmpp',
};
+my $Password = 'maelys';
my $sconf = {
sasl => {
mechanism => 'PLAIN',
callback => {
- getsecret => 'maelys',
+ getsecret => sub { $_[2]->($Password) },
},
},
host => 'localhost',
@@ -44,7 +45,7 @@ negotiate($cconf, $sconf, sub {
## invalid password
{
# hey callback could just be a subref that returns a localvar
- local $sconf->{sasl}{callback}{getsecret} = "x";
+ $Password = "x";
negotiate($cconf, $sconf, sub {
my ($clt, $srv) = @_;
@@ -55,8 +56,7 @@ negotiate($cconf, $sconf, sub {
## invalid password with different callback
{
- # hey callback could just be a subref that returns a localvar
- local $sconf->{sasl}{callback}{checkpass} = sub { 0 };
+ local $sconf->{sasl}{callback}{checkpass} = sub { $_[2]->(0) };
negotiate($cconf, $sconf, sub {
my ($clt, $srv) = @_;
View
31 t/server/digest_md5.t
@@ -18,7 +18,7 @@ my $authname;
my $sasl = Authen::SASL->new(
mechanism => 'DIGEST-MD5',
callback => {
- getsecret => 'fred',
+ getsecret => sub { $_[2]->('fred') },
},
);
ok($sasl,'new');
@@ -42,7 +42,9 @@ is($server->mechanism, 'DIGEST-MD5', 'conn mechanism');
'qop="auth"',
'realm="elwood.innosoft.com"';
- is(my $ss = $server->server_start(''), $expected_ss, 'server_start');
+ my $ss;
+ $server->server_start('', sub { $ss = shift });
+ is($ss, $expected_ss, 'server_start');
my $c1 = join ",", qw(
charset=utf-8
@@ -56,7 +58,8 @@ is($server->mechanism, 'DIGEST-MD5', 'conn mechanism');
username="gbarr"
);
- my $s1 = $server->server_step($c1);
+ my $s1;
+ $server->server_step($c1, sub { $s1 = shift });
ok $server->is_success, "This is the first and only step";
ok !$server->error, "no error" or diag $server->error;
ok !$server->need_step, "over";
@@ -75,7 +78,9 @@ is($server->mechanism, 'DIGEST-MD5', 'conn mechanism');
'qop="auth"',
'realm="elwood.innosoft.com"';
- is(my $ss = $server->server_start(''), $expected_ss, 'server_start');
+ my $ss;
+ $server->server_start('', sub { $ss = shift });
+ is($ss, $expected_ss, 'server_start');
ok !$server->is_success, "not success yet";
ok !$server->error, "no error" or diag $server->error;
ok $server->need_step, "we need one more step";
@@ -95,7 +100,8 @@ is($server->mechanism, 'DIGEST-MD5', 'conn mechanism');
username="gbarr"
);
- my $s1 = $server->server_step($c1);
+ my $s1;
+ $server->server_step($c1, sub { $s1 = shift });
is($s1, "rspauth=d10458627b2b6bb553d796f4d805fdd1", "rspauth")
or diag $server->error;
ok $server->is_success, "success!";
@@ -116,7 +122,9 @@ is($server->mechanism, 'DIGEST-MD5', 'conn mechanism');
'qop="auth,auth-conf,auth-int"',
'realm="elwood.innosoft.com"';
- is(my $ss = $server->server_start(''), $expected_ss, 'server_start');
+ my $ss;
+ $server->server_start('', sub { $ss = shift });
+ is($ss, $expected_ss, 'server_start');
my $c1 = join ",", qw(
charset=utf-8
@@ -130,7 +138,8 @@ is($server->mechanism, 'DIGEST-MD5', 'conn mechanism');
username="gbarr"
);
- my $s1 = $server->server_step($c1);
+ my $s1;
+ $server->server_step($c1, sub { $s1 = shift });
ok $server->is_success, "This is the first and only step";
ok !$server->error, "no error" or diag $server->error;
ok !$server->need_step, "over";
@@ -156,7 +165,7 @@ is($server->mechanism, 'DIGEST-MD5', 'conn mechanism');
username="gbarr"
);
- my $s1 = $server->server_step($c1);
+ $server->server_step($c1);
ok !$server->is_success, "Bad challenge";
like $server->error, qr/incorrect.*response/i, $server->error;
}
@@ -179,7 +188,7 @@ is($server->mechanism, 'DIGEST-MD5', 'conn mechanism');
username="gbarr"
);
- my $s1 = $server->server_step($c1);
+ $server->server_step($c1);
ok !$server->is_success, "Bad challenge";
like $server->error, qr/Bad.*challenge/i, $server->error;
}
@@ -201,11 +210,11 @@ is($server->mechanism, 'DIGEST-MD5', 'conn mechanism');
username="gbarr"
);
- my $s1 = $server->server_step($c1);
+ $server->server_step($c1);
ok $server->is_success, "first is success";
ok ! $server->error, "no error";
- my $s2 = $server->server_step($c1);
+ $server->server_step($c1);
ok !$server->is_success, "replay attack";
like $server->error, qr/nonce-count.*match/i, $server->error;
}
View
21 t/server/login.t
@@ -10,7 +10,7 @@ use_ok('Authen::SASL::Perl::LOGIN');
my %params = (
mechanism => 'LOGIN',
callback => {
- getsecret => 'secret',
+ getsecret => sub { use Carp; Carp::confess("x") unless $_[2]; $_[2]->('secret') },
},
);
@@ -26,16 +26,20 @@ is_failure("", "");
is_failure("xxx", "yyy", "zzz");
is_failure("a", "a", "a");
-is $server->server_start(""), "Username:";
-is $server->server_step("user"), "Password:";
-$server->server_step("secret");
+my $response; my $cb = sub { $response = shift };
+$server->server_start("", $cb),
+is $response, "Username:";
+$server->server_step("user", $cb);
+is $response, "Password:";
+$server->server_step("secret", $cb);
ok !$server->error, "no error" or diag $server->error;
ok $server->is_success, "success finally";
sub is_failure {
my $creds = shift;
my @steps = @_;
+ ## wouldn't really work in an async environemnt
$server->server_start("");
for (@steps) {
$server->server_step($_);
@@ -53,10 +57,11 @@ sub is_failure {
getsecret => "incorrect",
checkpass => sub {
my $self = shift;
- my ($username, $password) = @_;
- is $username, "foo", "username correct";
- is $password, "bar", "correct password";
- return 1;
+ my ($args, $cb) = @_;
+ is $args->{user}, "foo", "username correct";
+ is $args->{pass}, "bar", "correct password";
+ $cb->(1);
+ return;
}
},
);
View
57 t/server/plain.t
@@ -23,9 +23,28 @@ my %params = (
callback => {
getsecret => sub {
my $self = shift;
- my ($username, $authzid) = @_;
- return unless $username;
- return $creds{$authzid || "default"}{$username};
+ my ($args, $cb) = @_;
+ $cb->($creds{$args->{authname} || "default"}{$args->{user} || ""});
+ },
+ checkpass => sub {
+ my $self = shift;
+ my ($args, $cb) = @_;
+ $args ||= {};
+ my $username = $args->{user};
+ my $password = $args->{pass};
+ my $authzid = $args->{authname};
+ unless ($username) {
+ $cb->(0);
+ return;
+ }
+ my $expected = $creds{$authzid || "default"}{$username};
+ if ($expected && $expected eq ($password || "")) {
+ $cb->(1);
+ }
+ else {
+ $cb->(0);
+ }
+ return;
},
},
);
@@ -52,28 +71,20 @@ for my $authname ('', 'none') {
ok $server->is_success, "success finally";
}
-sub is_failure {
- my $creds = shift;
- my $msg = shift;
- $server->server_start($creds);
- ok !$server->is_success, $msg || "failure";
- like $server->error, qr/match/i, "failure";
-}
-
-
## testing checkpass callback, which takes precedence
## over getsecret when specified
%params = (
mechanism => 'PLAIN',
callback => {
- getsecret => "incorrect",
+ getsecret => sub { $_[2]->("incorrect") },
checkpass => sub {
my $self = shift;
- my ($username, $password, $realm) = @_;
- is $username, "yyy", "username correct";
- is $password, "zzz", "correct password";
- is $realm, "xxx", "correct realm";
- return 1;
+ my ($args, $cb) = @_;
+ is $args->{user}, "yyy", "username correct";
+ is $args->{pass}, "zzz", "correct password";
+ is $args->{authname}, "xxx", "correct realm";
+ $cb->(1);
+ return;
}
},
);
@@ -82,3 +93,13 @@ ok($ssasl = Authen::SASL->new( %params ), "new");
$server = $ssasl->server_new("ldap","localhost");
$server->server_start("xxx\0yyy\0zzz");
ok $server->is_success, "success";
+
+sub is_failure {
+ my $creds = shift;
+ my $msg = shift;
+ $server->server_start($creds);
+ ok !$server->is_success, $msg || "failure";
+ my $error = $server->error || "";
+ like $error, qr/match/i, "failure";
+}
+

0 comments on commit 44a633e

Please sign in to comment.
Something went wrong with that request. Please try again.