Permalink
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...
yannk authored and gbarr committed Mar 5, 2009
1 parent 339f43b commit 44a633e733560ed4d32de943acdf7c044c45a542
@@ -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 {
@@ -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;
@@ -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
@@ -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;
}
@@ -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 {
Oops, something went wrong.

0 comments on commit 44a633e

Please sign in to comment.