Permalink
Browse files

Added server support for PLAIN mechanism

  • Loading branch information...
1 parent ea10d97 commit 88444a3f74c9905df480b5e4ac413bbb20dd6b3c @yannk yannk committed with gbarr Jan 12, 2009
Showing with 100 additions and 7 deletions.
  1. +27 −5 lib/Authen/SASL/Perl.pm
  2. +26 −2 lib/Authen/SASL/Perl/PLAIN.pm
  3. +47 −0 t/server/plain.t
View
@@ -17,16 +17,20 @@ my %secflags = (
);
my %have;
-sub client_new {
+sub client_new { _new(@_) }
+sub server_new { _new(@_) }
+
+sub _new {
my ($pkg, $parent, $service, $host, $secflags) = @_;
my @sec = grep { $secflags{$_} } split /\W+/, lc($secflags || '');
my $self = {
- callback => { %{$parent->callback} },
- service => $service || '',
- host => $host || '',
- debug => $parent->{debug} || 0,
+ callback => { %{$parent->callback} },
+ service => $service || '',
+ host => $host || '',
+ debug => $parent->{debug} || 0,
+ need_step => 1,
};
my @mpkg = sort {
@@ -49,6 +53,22 @@ sub error { shift->{error} }
sub service { shift->{service} }
sub host { shift->{host} }
+sub need_step {
+ my $self = shift;
+ return 0 if $self->{error};
+ return $self->{need_step};
+}
+
+sub set_success {
+ my $self = shift;
+ $self->{need_step} = 0;
+}
+
+sub is_success {
+ my $self = shift;
+ return !$self->code && !$self->need_step;
+}
+
sub set_error {
my $self = shift;
$self->{error} = shift;
@@ -80,6 +100,8 @@ sub callback {
sub mechanism { undef }
sub client_step { undef }
sub client_start { undef }
+sub server_step { undef }
+sub server_start { undef }
# Private methods used by Authen::SASL::Perl that
# may be overridden in mechanism sub-calsses
@@ -14,6 +14,8 @@ my %secflags = (
noanonymous => 1,
);
+my @tokens = qw(authname user pass);
+
sub _order { 1 }
sub _secflags {
shift;
@@ -24,15 +26,33 @@ sub mechanism { 'PLAIN' }
sub client_start {
my $self = shift;
+ $self->{error} = undef;
my @parts = map {
my $v = $self->_call($_);
defined($v) ? $v : ''
- } qw(authname user pass);
+ } @tokens;
join("\0", @parts);
}
+sub server_start {
+ my $self = shift;
+ my $challenge = shift;
+
+ $self->{error} = undef;
+ return unless defined $challenge;
+
+ my %parts;
+ @parts{@tokens} = split "\0", $challenge, scalar @tokens;
+ for (@tokens) {
+ return $self->set_error("Credentials don't match")
+ unless (($parts{$_} || "" ) eq ($self->_call($_) || ""));
+ }
+ $self->set_success;
+ return 1;
+}
+
1;
__END__
@@ -55,7 +75,7 @@ Authen::SASL::Perl::PLAIN - Plain Login Authentication class
=head1 DESCRIPTION
-This method implements the client part of the PLAIN SASL algorithm,
+This method implements the client and server part of the PLAIN SASL algorithm,
as described in RFC 2595 resp. IETF Draft draft-ietf-sasl-plain-XX.txt
=head2 CALLBACK
@@ -101,4 +121,8 @@ Documentation Copyright (c) 2004 Peter Marschall.
All rights reserved. This documentation is distributed,
and may be redistributed, under the same terms as Perl itself.
+Server support Copyright (c) 2009 Yann Kerherve.
+All rights reserved. This program is free software; you can redistribute
+it and/or modify it under the same terms as Perl itself.
+
=cut
View
@@ -0,0 +1,47 @@
+#!perl
+
+use Test::More tests => 42;
+
+use Authen::SASL qw(Perl);
+use_ok('Authen::SASL::Perl::PLAIN');
+
+my $authname;
+my %params = (
+ mechanism => 'PLAIN',
+ callback => {
+ user => 'yann',
+ pass => 'maelys',
+ authname => sub { $authname },
+ },
+);
+
+ok(my $ssasl = Authen::SASL->new( %params ), "new");
+
+is($ssasl->mechanism, 'PLAIN', 'sasl mechanism');
+
+my $server = $ssasl->server_new("ldap","localhost");
+is($server->mechanism, 'PLAIN', 'server mechanism');
+
+for ('', 'none') {
+ $authname = $_;
+ is_failure("");
+ is_failure("xxx");
+ is_failure("\0\0\0\0\0\0\0");
+ is_failure("\0\0\0\0\0\0\0$authname\0yann\0maelys");
+ is_failure("yann\0maelys\0$authname", "wrong order");
+ is_failure("$authname\0YANN\0maelys", "case matters");
+ is_failure("$authname\0yann\n\0maelys", "extra stuff");
+ is_failure("$authname\0yann\0\0maelys", "double null");
+ is_failure("$authname\0yann\0maelys\0trailing", "trailing");
+
+ $server->server_start("$authname\0yann\0maelys");
+ 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";
+}

0 comments on commit 88444a3

Please sign in to comment.