#!perl
use strict;
use warnings;
use Test::More tests => 67;
use Authen::SASL qw(Perl);
use_ok('Authen::SASL::Perl::PLAIN');
my %creds = (
default => {
yann => "maelys",
YANN => "MAELYS",
},
none => {
yann => "maelys",
YANN => "MAELYS",
},
);
my %params = (
mechanism => 'PLAIN',
callback => {
getsecret => sub {
my $self = shift;
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;
},
},
);
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 my $authname ('', 'none') {
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");
my $cb;
$server->server_start("$authname\0yann\0maelys", sub { $cb = 1 });
ok $cb, "callback called";
ok $server->is_success, "success finally";
}
## testing checkpass callback, which takes precedence
## over getsecret when specified
%params = (
mechanism => 'PLAIN',
callback => {
getsecret => sub { $_[2]->("incorrect") },
checkpass => sub {
my $self = shift;
my ($args, $cb) = @_;
is $args->{user}, "yyy", "username correct";
is $args->{pass}, "zzz", "correct password";
is $args->{authname}, "xxx", "correct realm";
$cb->(1);
return;
}
},
);
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;
my $cb;
$server->server_start($creds, sub { $cb = 1 });
ok $cb, 'callback called';
ok !$server->is_success, $msg || "failure";
my $error = $server->error || "";
like $error, qr/match/i, "failure";
}