|
Packit |
ae5a87 |
# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
|
|
Packit |
ae5a87 |
# This program is free software; you can redistribute it and/or
|
|
Packit |
ae5a87 |
# modify it under the same terms as Perl itself.
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
package Authen::SASL::Perl;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
use strict;
|
|
Packit |
ae5a87 |
use vars qw($VERSION);
|
|
Packit |
ae5a87 |
use Carp;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
$VERSION = "2.14";
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
my %secflags = (
|
|
Packit |
ae5a87 |
noplaintext => 1,
|
|
Packit |
ae5a87 |
noanonymous => 1,
|
|
Packit |
ae5a87 |
nodictionary => 1,
|
|
Packit |
ae5a87 |
);
|
|
Packit |
ae5a87 |
my %have;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub server_new {
|
|
Packit |
ae5a87 |
my ($pkg, $parent, $service, $host, $options) = @_;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
my $self = {
|
|
Packit |
ae5a87 |
callback => { %{$parent->callback} },
|
|
Packit |
ae5a87 |
service => $service || '',
|
|
Packit |
ae5a87 |
host => $host || '',
|
|
Packit |
ae5a87 |
debug => $parent->{debug} || 0,
|
|
Packit |
ae5a87 |
need_step => 1,
|
|
Packit |
ae5a87 |
};
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
my $mechanism = $parent->mechanism
|
|
Packit |
ae5a87 |
or croak "No server mechanism specified";
|
|
Packit |
ae5a87 |
$mechanism =~ s/^\s*\b(.*)\b\s*$/$1/g;
|
|
Packit |
ae5a87 |
$mechanism =~ s/-/_/g;
|
|
Packit |
ae5a87 |
$mechanism = uc $mechanism;
|
|
Packit |
ae5a87 |
my $mpkg = __PACKAGE__ . "::$mechanism";
|
|
Packit |
ae5a87 |
eval "require $mpkg;"
|
|
Packit |
ae5a87 |
or croak "Cannot use $mpkg for " . $parent->mechanism;
|
|
Packit |
ae5a87 |
my $server = $mpkg->_init($self);
|
|
Packit |
ae5a87 |
$server->_init_server($options);
|
|
Packit |
ae5a87 |
return $server;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub client_new {
|
|
Packit |
ae5a87 |
my ($pkg, $parent, $service, $host, $secflags) = @_;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
my @sec = grep { $secflags{$_} } split /\W+/, lc($secflags || '');
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
my $self = {
|
|
Packit |
ae5a87 |
callback => { %{$parent->callback} },
|
|
Packit |
ae5a87 |
service => $service || '',
|
|
Packit |
ae5a87 |
host => $host || '',
|
|
Packit |
ae5a87 |
debug => $parent->{debug} || 0,
|
|
Packit |
ae5a87 |
need_step => 1,
|
|
Packit |
ae5a87 |
};
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
my @mpkg = sort {
|
|
Packit |
ae5a87 |
$b->_order <=> $a->_order
|
|
Packit |
ae5a87 |
} grep {
|
|
Packit |
ae5a87 |
my $have = $have{$_} ||= (eval "require $_;" and $_->can('_secflags')) ? 1 : -1;
|
|
Packit |
ae5a87 |
$have > 0 and $_->_secflags(@sec) == @sec
|
|
Packit |
ae5a87 |
} map {
|
|
Packit |
ae5a87 |
(my $mpkg = __PACKAGE__ . "::$_") =~ s/-/_/g;
|
|
Packit |
ae5a87 |
$mpkg;
|
|
Packit |
ae5a87 |
} split /[^-\w]+/, $parent->mechanism
|
|
Packit |
ae5a87 |
or croak "No SASL mechanism found\n";
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
$mpkg[0]->_init($self);
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub _init_server {}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub _order { 0 }
|
|
Packit |
ae5a87 |
sub code { defined(shift->{error}) || 0 }
|
|
Packit |
ae5a87 |
sub error { shift->{error} }
|
|
Packit |
ae5a87 |
sub service { shift->{service} }
|
|
Packit |
ae5a87 |
sub host { shift->{host} }
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub need_step {
|
|
Packit |
ae5a87 |
my $self = shift;
|
|
Packit |
ae5a87 |
return 0 if $self->{error};
|
|
Packit |
ae5a87 |
return $self->{need_step};
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
## I think I need to rename that to end()?
|
|
Packit |
ae5a87 |
## It doesn't mean that SASL is successful, but that
|
|
Packit |
ae5a87 |
## that the negotiation is over, no more step necessary
|
|
Packit |
ae5a87 |
## at least for the client
|
|
Packit |
ae5a87 |
sub set_success {
|
|
Packit |
ae5a87 |
my $self = shift;
|
|
Packit |
ae5a87 |
$self->{need_step} = 0;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub is_success {
|
|
Packit |
ae5a87 |
my $self = shift;
|
|
Packit |
ae5a87 |
return !$self->code && !$self->need_step;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub set_error {
|
|
Packit |
ae5a87 |
my $self = shift;
|
|
Packit |
ae5a87 |
$self->{error} = shift;
|
|
Packit |
ae5a87 |
return;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# set/get property
|
|
Packit |
ae5a87 |
sub property {
|
|
Packit |
ae5a87 |
my $self = shift;
|
|
Packit |
ae5a87 |
my $prop = $self->{property} ||= {};
|
|
Packit |
ae5a87 |
return $prop->{ $_[0] } if @_ == 1;
|
|
Packit |
ae5a87 |
my %new = @_;
|
|
Packit |
ae5a87 |
@{$prop}{keys %new} = values %new;
|
|
Packit |
ae5a87 |
1;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub callback {
|
|
Packit |
ae5a87 |
my $self = shift;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
return $self->{callback}{$_[0]} if @_ == 1;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
my %new = @_;
|
|
Packit |
ae5a87 |
@{$self->{callback}}{keys %new} = values %new;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
$self->{callback};
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# Should be defined in the mechanism sub-class
|
|
Packit |
ae5a87 |
sub mechanism { undef }
|
|
Packit |
ae5a87 |
sub client_step { undef }
|
|
Packit |
ae5a87 |
sub client_start { undef }
|
|
Packit |
ae5a87 |
sub server_step { undef }
|
|
Packit |
ae5a87 |
sub server_start { undef }
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# Private methods used by Authen::SASL::Perl that
|
|
Packit |
ae5a87 |
# may be overridden in mechanism sub-calsses
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub _init {
|
|
Packit |
ae5a87 |
my ($pkg, $href) = @_;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
bless $href, $pkg;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub _call {
|
|
Packit |
ae5a87 |
my ($self, $name) = splice(@_,0,2);
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
my $cb = $self->{callback}{$name};
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
return undef unless defined $cb;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
my $value;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
if (ref($cb) eq 'ARRAY') {
|
|
Packit |
ae5a87 |
my @args = @$cb;
|
|
Packit |
ae5a87 |
$cb = shift @args;
|
|
Packit |
ae5a87 |
$value = $cb->($self, @args);
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
elsif (ref($cb) eq 'CODE') {
|
|
Packit |
ae5a87 |
$value = $cb->($self, @_);
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
else {
|
|
Packit |
ae5a87 |
$value = $cb;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
$self->{answer}{$name} = $value
|
|
Packit |
ae5a87 |
unless $name eq 'pass'; # Do not store password
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
return $value;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# TODO: Need a better name than this
|
|
Packit |
ae5a87 |
sub answer {
|
|
Packit |
ae5a87 |
my ($self, $name) = @_;
|
|
Packit |
ae5a87 |
$self->{answer}{$name};
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub _secflags { 0 }
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub securesocket {
|
|
Packit |
ae5a87 |
my $self = shift;
|
|
Packit |
ae5a87 |
return $_[0] unless (defined($self->property('ssf')) && $self->property('ssf') > 0);
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
local *GLOB; # avoid used only once warning
|
|
Packit |
ae5a87 |
my $glob = \do { local *GLOB; };
|
|
Packit |
ae5a87 |
tie(*$glob, 'Authen::SASL::Perl::Layer', $_[0], $self);
|
|
Packit |
ae5a87 |
$glob;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
{
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
#
|
|
Packit |
ae5a87 |
# Add SASL encoding/decoding to a filehandle
|
|
Packit |
ae5a87 |
#
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
package Authen::SASL::Perl::Layer;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
use bytes;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
require Tie::Handle;
|
|
Packit |
ae5a87 |
our @ISA = qw(Tie::Handle);
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub TIEHANDLE {
|
|
Packit |
ae5a87 |
my ($class, $fh, $conn) = @_;
|
|
Packit |
ae5a87 |
my $self;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
warn __PACKAGE__ . ': non-blocking handle may not work'
|
|
Packit |
ae5a87 |
if ($fh->can('blocking') and not $fh->blocking());
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
$self->{fh} = $fh;
|
|
Packit |
ae5a87 |
$self->{conn} = $conn;
|
|
Packit |
ae5a87 |
$self->{readbuflen} = 0;
|
|
Packit |
ae5a87 |
$self->{sndbufsz} = $conn->property('maxout');
|
|
Packit |
ae5a87 |
$self->{rcvbufsz} = $conn->property('maxbuf');
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
return bless($self, $class);
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub CLOSE {
|
|
Packit |
ae5a87 |
my ($self) = @_;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# forward close to the inner handle
|
|
Packit |
ae5a87 |
close($self->{fh});
|
|
Packit |
ae5a87 |
delete $self->{fh};
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub DESTROY {
|
|
Packit |
ae5a87 |
my ($self) = @_;
|
|
Packit |
ae5a87 |
delete $self->{fh};
|
|
Packit |
ae5a87 |
undef $self;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub FETCH {
|
|
Packit |
ae5a87 |
my ($self) = @_;
|
|
Packit |
ae5a87 |
return $self->{fh};
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub FILENO {
|
|
Packit |
ae5a87 |
my ($self) = @_;
|
|
Packit |
ae5a87 |
return fileno($self->{fh});
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
sub READ {
|
|
Packit |
ae5a87 |
my ($self, $buf, $len, $offset) = @_;
|
|
Packit |
ae5a87 |
my $debug = $self->{conn}->{debug};
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
$buf = \$_[1];
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
my $avail = $self->{readbuflen};
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
print STDERR " [READ(len=$len,offset=$offset)] avail=$avail;\n"
|
|
Packit |
ae5a87 |
if ($debug & 4);
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# Check if there's leftovers from a previous READ
|
|
Packit |
ae5a87 |
if ($avail <= 0) {
|
|
Packit |
ae5a87 |
$avail = $self->_getbuf();
|
|
Packit |
ae5a87 |
return undef unless ($avail > 0);
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# if there's more than we need right now, leave the rest for later
|
|
Packit |
ae5a87 |
if ($avail >= $len) {
|
|
Packit |
ae5a87 |
print STDERR " GOT ALL: avail=$avail; need=$len\n"
|
|
Packit |
ae5a87 |
if ($debug & 4);
|
|
Packit |
ae5a87 |
substr($$buf, $offset, $len) = substr($self->{readbuf}, 0, $len, '');
|
|
Packit |
ae5a87 |
$self->{readbuflen} -= $len;
|
|
Packit |
ae5a87 |
return ($len);
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# there's not enough; take all we have, read more on next call
|
|
Packit |
ae5a87 |
print STDERR " GOT PARTIAL: avail=$avail; need=$len\n"
|
|
Packit |
ae5a87 |
if ($debug & 4);
|
|
Packit |
ae5a87 |
substr($$buf, $offset || 0, $avail) = $self->{readbuf};
|
|
Packit |
ae5a87 |
$self->{readbuf} = '';
|
|
Packit |
ae5a87 |
$self->{readbuflen} = 0;
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
return ($avail);
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# retrieve and decode a buffer of cipher text in SASL format
|
|
Packit |
ae5a87 |
sub _getbuf {
|
|
Packit |
ae5a87 |
my ($self) = @_;
|
|
Packit |
ae5a87 |
my $debug = $self->{conn}->{debug};
|
|
Packit |
ae5a87 |
my $fh = $self->{fh};
|
|
Packit |
ae5a87 |
my $buf = '';
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# first, read 4-octet buffer size
|
|
Packit |
ae5a87 |
my $n = 0;
|
|
Packit |
ae5a87 |
while ($n < 4) {
|
|
Packit |
ae5a87 |
my $rv = sysread($fh, $buf, 4 - $n, $n);
|
|
Packit |
ae5a87 |
print STDERR " [getbuf: sysread($fh,$buf,4-$n,$n)=$rv: $!\n"
|
|
Packit |
ae5a87 |
if ($debug & 4);
|
|
Packit |
ae5a87 |
return $rv unless $rv > 0;
|
|
Packit |
ae5a87 |
$n += $rv;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# size is encoded in network byte order
|
|
Packit |
ae5a87 |
my ($bsz) = unpack('N', $buf);
|
|
Packit |
ae5a87 |
print STDERR " [getbuf: cipher buffer sz=$bsz]\n" if ($debug & 4);
|
|
Packit |
ae5a87 |
return undef unless ($bsz <= $self->{rcvbufsz});
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# next, read actual cipher text
|
|
Packit |
ae5a87 |
$buf = '';
|
|
Packit |
ae5a87 |
$n = 0;
|
|
Packit |
ae5a87 |
while ($n < $bsz) {
|
|
Packit |
ae5a87 |
my $rv = sysread($fh, $buf, $bsz - $n, $n);
|
|
Packit |
ae5a87 |
print STDERR " [getbuf: got o=$n,n=", $bsz - $n, ",rv=$rv,bl=" . length($buf) . "]\n"
|
|
Packit |
ae5a87 |
if ($debug & 4);
|
|
Packit |
ae5a87 |
return $rv unless $rv > 0;
|
|
Packit |
ae5a87 |
$n += $rv;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# call mechanism specific decoding routine
|
|
Packit |
ae5a87 |
$self->{readbuf} = $self->{conn}->decode($buf, $bsz);
|
|
Packit |
ae5a87 |
$n = length($self->{readbuf});
|
|
Packit |
ae5a87 |
print STDERR " [getbuf: clear text buffer sz=$n]\n" if ($debug & 4);
|
|
Packit |
ae5a87 |
$self->{readbuflen} = $n;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# Encrypting a write() to a filehandle is much easier than reading, because
|
|
Packit |
ae5a87 |
# all the data to be encrypted is immediately available
|
|
Packit |
ae5a87 |
sub WRITE {
|
|
Packit |
ae5a87 |
my ($self, undef, $len, $offset) = @_;
|
|
Packit |
ae5a87 |
my $debug = $self->{conn}->{debug};
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
my $fh = $self->{fh};
|
|
Packit |
ae5a87 |
|
|
Packit Service |
85c7a0 |
# Fix for BZ#965739, RT#85294
|
|
Packit Service |
85c7a0 |
$len = length($_[1]) if $len > length($_[1]);
|
|
Packit Service |
85c7a0 |
|
|
Packit |
ae5a87 |
# put on wire in peer-sized chunks
|
|
Packit |
ae5a87 |
my $bsz = $self->{sndbufsz};
|
|
Packit |
ae5a87 |
while ($len > 0) {
|
|
Packit |
ae5a87 |
print STDERR " [WRITE: chunk $bsz/$len]\n"
|
|
Packit |
ae5a87 |
if ($debug & 8);
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
# call mechanism specific encoding routine
|
|
Packit |
ae5a87 |
my $x = $self->{conn}->encode(substr($_[1], $offset || 0, $bsz));
|
|
Packit |
ae5a87 |
print $fh pack('N', length($x)), $x;
|
|
Packit |
ae5a87 |
$len -= $bsz;
|
|
Packit |
ae5a87 |
$offset += $bsz;
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
return $_[2];
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
}
|
|
Packit |
ae5a87 |
|
|
Packit |
ae5a87 |
1;
|