Permalink
Browse files

Added server LOGIN support for fun

  • Loading branch information...
yannk authored and gbarr committed Jan 16, 2009
1 parent d7e4974 commit 33e99d91a9f7147def60c560af92d0165a86917d
Showing with 210 additions and 5 deletions.
  1. +71 −2 lib/Authen/SASL/Perl/LOGIN.pm
  2. +1 −1 lib/Authen/SASL/Perl/PLAIN.pm
  3. +67 −0 t/negotiations/login.t
  4. +2 −2 t/negotiations/plain.t
  5. +69 −0 t/server/login.t
@@ -31,12 +31,64 @@ sub client_step {
my ($self, $string) = @_;
$string =~ /password/i
- ? $self->_call('pass')
+ ? do { $self->set_success; $self->_call('pass') }
: $string =~ /username/i
? $self->_call('user')
: '';
}
+sub server_start {
+ my $self = shift;
+ my $response = shift;
+
+ $self->{answer} = {};
+ $self->{stage} = 0;
+ $self->{need_step} = 1;
+ $self->{error} = undef;
+ return 'Username:';
+}
+
+sub server_step {
+ my $self = shift;
+ my $response = shift;
+
+ my $stage = ++$self->{stage};
+
+ if ($stage == 1) {
+ return $self->set_error("Invalid sequence (empty username)")
+ unless defined $response;
+ $self->{answer}{user} = $response;
+ return "Password:";
+ }
+ elsif ($stage == 2) {
+ return $self->set_error("Invalid sequence (empty pass)")
+ unless defined $response;
+ $self->{answer}{pass} = $response;
+ }
+ else {
+ return $self->set_error("Invalid sequence (end)");
+ }
+
+ 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 $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;
+}
+
1;
__END__
@@ -59,13 +111,15 @@ Authen::SASL::Perl::LOGIN - Login Authentication class
=head1 DESCRIPTION
-This method implements the client part of the LOGIN SASL algorithm,
+This method implements the client and server part of the LOGIN SASL algorithm,
as described in IETF Draft draft-murchison-sasl-login-XX.txt.
=head2 CALLBACK
The callbacks used are:
+=head3 Client
+
=over 4
=item user
@@ -78,6 +132,21 @@ The user's password to be used for authentication
=back
+=head3 Server
+
+=over4
+
+=item getsecret(username)
+
+returns the password associated with C<username>
+
+=item checkpass(username, password)
+
+returns true and false depending on the validity of the credentials passed
+in arguments.
+
+=back
+
=head1 SEE ALSO
L<Authen::SASL>,
@@ -52,7 +52,7 @@ sub server_start {
# I'm not entirely sure of what I am doing
$self->{answer}{$_} = $parts{$_} for qw/authname user/;
- if ($self->callback('checkpass')) {
+ if (defined $self->callback('checkpass')) {
if ($self->_call('checkpass', @parts{qw/user pass authname/}) ) {
$self->set_success;
return 1;
View
@@ -0,0 +1,67 @@
+#!perl
+
+use Test::More tests => 9;
+
+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 => 'LOGIN',
+ callback => {
+ user => 'yann',
+ pass => 'maelys',
+ },
+ },
+ host => 'localhost',
+ service => 'xmpp',
+};
+
+my $sconf = {
+ sasl => {
+ mechanism => 'LOGIN',
+ callback => {
+ getsecret => 'maelys',
+ },
+ },
+ host => 'localhost',
+ service => 'xmpp',
+};
+
+## base negotiation should work
+$DB::single=1;
+negotiate($cconf, $sconf, sub {
+ my ($clt, $srv) = @_;
+ is $clt->mechanism, "LOGIN";
+ is $srv->mechanism, "LOGIN";
+ 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}{getsecret} = "wrong";
+
+ 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}{checkpass} = sub { 0 };
+
+ negotiate($cconf, $sconf, sub {
+ my ($clt, $srv) = @_;
+ ok ! $srv->is_success, "wrong pass";
+ like $srv->error, qr/match/, "error set";
+ });
+}
View
@@ -53,10 +53,10 @@ 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}{getsecret} = "x";
+ local $sconf->{sasl}{callback}{checkpass} = sub { 0 };
negotiate($cconf, $sconf, sub {
my ($clt, $srv) = @_;
View
@@ -0,0 +1,69 @@
+#!perl
+use strict;
+use warnings;
+
+use Test::More tests => 20;
+
+use Authen::SASL qw(Perl);
+use_ok('Authen::SASL::Perl::LOGIN');
+
+my %params = (
+ mechanism => 'LOGIN',
+ callback => {
+ getsecret => 'secret',
+ },
+);
+
+ok(my $ssasl = Authen::SASL->new( %params ), "new");
+
+is($ssasl->mechanism, 'LOGIN', 'sasl mechanism');
+
+my $server = $ssasl->server_new("xmpp","localhost");
+is($server->mechanism, 'LOGIN', 'server mechanism');
+
+is_failure();
+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");
+
+ok !$server->error, "no error" or diag $server->error;
+ok $server->is_success, "success finally";
+
+sub is_failure {
+ my $creds = shift;
+ my @steps = @_;
+ $server->server_start("");
+ for (@steps) {
+ $server->server_step($_);
+ }
+ ok !$server->is_success, "failure";
+ ok ($server->need_step or $server->error), "no success means that";
+}
+
+
+## testing checkpass callback, which takes precedence
+## over getsecret when specified
+%params = (
+ mechanism => 'LOGIN',
+ callback => {
+ getsecret => "incorrect",
+ checkpass => sub {
+ my $self = shift;
+ my ($username, $password) = @_;
+ is $username, "foo", "username correct";
+ is $password, "bar", "correct password";
+ return 1;
+ }
+ },
+);
+
+ok($ssasl = Authen::SASL->new( %params ), "new");
+$server = $ssasl->server_new("ldap","localhost");
+$server->server_start("");
+$server->server_step("foo");
+$server->server_step("bar");
+ok $server->is_success, "success";

0 comments on commit 33e99d9

Please sign in to comment.