Skip to content

Commit

Permalink
Transformed server_start and server_step to use callbacks
Browse files Browse the repository at this point in the history 
allowing me to execute SASL negotiations fully asynchronously within
djabberd.

Tests are still expecting a linear run
  • Loading branch information
@yannk @gbarr
yannk authored and gbarr committed Sep 24, 2009
1 parent 339f43b commit 44a633e
Show file tree
Hide file tree
Showing 10 changed files with 246 additions and 138 deletions.
100 changes: 64 additions & 36 deletions lib/Authen/SASL/Perl/DIGEST_MD5.pm
View file
Expand Up @@ -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;
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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};

Expand All @@ -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 {
Expand Down Expand Up @@ -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 {
Expand Down
74 changes: 49 additions & 25 deletions lib/Authen/SASL/Perl/LOGIN.pm
View file
Expand Up @@ -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;
Expand Down
59 changes: 39 additions & 20 deletions lib/Authen/SASL/Perl/PLAIN.pm
View file
Expand Up @@ -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")
Expand All @@ -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;
Expand Down Expand Up @@ -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
Expand Down
8 changes: 6 additions & 2 deletions t/lib/common.pl
View file
Expand Up @@ -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;
}
Expand Down
12 changes: 6 additions & 6 deletions t/negotiations/digest_md5.t
View file
Expand Up @@ -23,7 +23,7 @@ my $sconf = {
sasl => {
mechanism => 'DIGEST-MD5',
callback => {
getsecret => 'maelys',
getsecret => sub { $_[2]->('maelys') },
},
},
host => 'localhost',
Expand Down Expand Up @@ -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 {
Expand Down

0 comments on commit 44a633e

Please sign in to comment.