p147685/CardiacPhase
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Initial class construction

Browse Source
This commit is contained in:
João Narciso
2019-05-06 16:34:28 +02:00
parent 67f2d57e03
commit 431ff5f7d4
5813 changed files with 1622108 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

130
Git/usr/share/perl5/vendor_perl/Authen/SASL.pm Normal file
View File

@ -0,0 +1,130 @@
# Copyright (c) 2004-2006 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL;
use strict;
use vars qw($VERSION @Plugins);
use Carp;
$VERSION = "2.16";
@Plugins = qw(
Authen::SASL::XS
Authen::SASL::Cyrus
Authen::SASL::Perl
);
sub import {
shift;
return unless @_;
local $SIG{__DIE__};
@Plugins = grep { /^[:\w]+$/ and eval "require $_" } map { /::/ ? $_ : "Authen::SASL::$_" } @_
or croak "no valid Authen::SASL plugins found";
}
sub new {
my $pkg = shift;
my %opt = ((@_ % 2 ? 'mechanism' : ()), @_);
my $self = bless {
mechanism => $opt{mechanism} || $opt{mech},
callback => {},
debug => $opt{debug},
}, $pkg;
$self->callback(%{$opt{callback}}) if ref($opt{callback}) eq 'HASH';
# Compat
$self->callback(user => ($self->{user} = $opt{user})) if exists $opt{user};
$self->callback(pass => $opt{password}) if exists $opt{password};
$self->callback(pass => $opt{response}) if exists $opt{response};
$self;
}
sub mechanism {
my $self = shift;
@_ ? $self->{mechanism} = shift
: $self->{mechanism};
}
sub callback {
my $self = shift;
return $self->{callback}{$_[0]} if @_ == 1;
my %new = @_;
@{$self->{callback}}{keys %new} = values %new;
$self->{callback};
}
# The list of packages should not really be hardcoded here
# We need some way to discover what plugins are installed
sub client_new { # $self, $service, $host, $secflags
my $self = shift;
my $err;
foreach my $pkg (@Plugins) {
if (eval "require $pkg" and $pkg->can("client_new")) {
if ($self->{conn} = eval { $pkg->client_new($self, @_) }) {
return $self->{conn};
}
$err = $@;
}
}
croak $err || "Cannot find a SASL Connection library";
}
sub server_new { # $self, $service, $host, $secflags
my $self = shift;
my $err;
foreach my $pkg (@Plugins) {
if (eval "require $pkg" and $pkg->can("server_new")) {
if ($self->{conn} = eval { $pkg->server_new($self, @_) } ) {
return $self->{conn};
}
$err = $@;
}
}
croak $err || "Cannot find a SASL Connection library for server-side authentication";
}
sub error {
my $self = shift;
$self->{conn} && $self->{conn}->error;
}
# Compat.
sub user {
my $self = shift;
my $user = $self->{callback}{user};
$self->{callback}{user} = shift if @_;
$user;
}
sub challenge {
my $self = shift;
$self->{conn}->client_step(@_);
}
sub initial {
my $self = shift;
$self->client_new($self)->client_start;
}
sub name {
my $self = shift;
$self->{conn} ? $self->{conn}->mechanism : ($self->{mechanism} =~ /(\S+)/)[0];
}
1;

18
Git/usr/share/perl5/vendor_perl/Authen/SASL/CRAM_MD5.pm Normal file
View File

@ -0,0 +1,18 @@
# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL::CRAM_MD5;
use strict;
use vars qw($VERSION);
$VERSION = "2.14";
sub new {
shift;
Authen::SASL->new(@_, mechanism => 'CRAM-MD5');
}
1;

18
Git/usr/share/perl5/vendor_perl/Authen/SASL/EXTERNAL.pm Normal file
View File

@ -0,0 +1,18 @@
# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL::EXTERNAL;
use strict;
use vars qw($VERSION);
$VERSION = "2.14";
sub new {
shift;
Authen::SASL->new(@_, mechanism => 'EXTERNAL');
}
1;

344
Git/usr/share/perl5/vendor_perl/Authen/SASL/Perl.pm Normal file
View File

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

93
Git/usr/share/perl5/vendor_perl/Authen/SASL/Perl/ANONYMOUS.pm Normal file
View File

@ -0,0 +1,93 @@
# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL::Perl::ANONYMOUS;
use strict;
use vars qw($VERSION @ISA);
$VERSION = "2.14";
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
noplaintext => 1,
);
sub _order { 0 }
sub _secflags {
shift;
grep { $secflags{$_} } @_;
}
sub mechanism { 'ANONYMOUS' }
sub client_start {
shift->_call('authname')
}
sub client_step {
shift->_call('authname')
}
1;
__END__
=head1 NAME
Authen::SASL::Perl::ANONYMOUS - Anonymous Authentication class
=head1 SYNOPSIS
use Authen::SASL qw(Perl);
$sasl = Authen::SASL->new(
mechanism => 'ANONYMOUS',
callback => {
authname => $mailaddress
},
);
=head1 DESCRIPTION
This method implements the client part of the ANONYMOUS SASL algorithm,
as described in RFC 2245 resp. in IETF Draft draft-ietf-sasl-anon-XX.txt.
=head2 CALLBACK
The callbacks used are:
=over 4
=item authname
email address or UTF-8 encoded string to be used as
trace information for the server
=back
=head1 SEE ALSO
L<Authen::SASL>,
L<Authen::SASL::Perl>
=head1 AUTHORS
Software written by Graham Barr <gbarr@pobox.com>,
documentation written by Peter Marschall <peter@adpm.de>.
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap@perl.org>
=head1 COPYRIGHT
Copyright (c) 2002-2004 Graham Barr.
All rights reserved. This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
Documentation Copyright (c) 2004 Peter Marschall.
All rights reserved. This documentation is distributed,
and may be redistributed, under the same terms as Perl itself.
=cut

105
Git/usr/share/perl5/vendor_perl/Authen/SASL/Perl/CRAM_MD5.pm Normal file
View File

@ -0,0 +1,105 @@
# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL::Perl::CRAM_MD5;
use strict;
use vars qw($VERSION @ISA);
use Digest::HMAC_MD5 qw(hmac_md5_hex);
$VERSION = "2.14";
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
noplaintext => 1,
noanonymous => 1,
);
sub _order { 2 }
sub _secflags {
shift;
scalar grep { $secflags{$_} } @_;
}
sub mechanism { 'CRAM-MD5' }
sub client_start {
'';
}
sub client_step {
my ($self, $string) = @_;
my ($user, $pass) = map {
my $v = $self->_call($_);
defined($v) ? $v : ''
} qw(user pass);
$user . " " . hmac_md5_hex($string,$pass);
}
1;
__END__
=head1 NAME
Authen::SASL::Perl::CRAM_MD5 - CRAM MD5 Authentication class
=head1 SYNOPSIS
use Authen::SASL qw(Perl);
$sasl = Authen::SASL->new(
mechanism => 'CRAM-MD5',
callback => {
user => $user,
pass => $pass
},
);
=head1 DESCRIPTION
This method implements the client part of the CRAM-MD5 SASL algorithm,
as described in RFC 2195 resp. in IETF Draft draft-ietf-sasl-crammd5-XX.txt.
=head2 CALLBACK
The callbacks used are:
=over 4
=item user
The username to be used for authentication
=item pass
The user's password to be used for authentication
=back
=head1 SEE ALSO
L<Authen::SASL>,
L<Authen::SASL::Perl>
=head1 AUTHORS
Software written by Graham Barr <gbarr@pobox.com>,
documentation written by Peter Marschall <peter@adpm.de>.
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap@perl.org>
=head1 COPYRIGHT
Copyright (c) 2002-2004 Graham Barr.
All rights reserved. This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
Documentation Copyright (c) 2004 Peter Marschall.
All rights reserved. This documentation is distributed,
and may be redistributed, under the same terms as Perl itself.
=cut

877
Git/usr/share/perl5/vendor_perl/Authen/SASL/Perl/DIGEST_MD5.pm Normal file
View File

@ -0,0 +1,877 @@
# Copyright (c) 2003-2009 Graham Barr, Djamel Boudjerda, Paul Connolly, Julian
# Onions, Nexor and 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.
# See http://www.ietf.org/rfc/rfc2831.txt for details
package Authen::SASL::Perl::DIGEST_MD5;
use strict;
use vars qw($VERSION @ISA $CNONCE $NONCE);
use Digest::MD5 qw(md5_hex md5);
use Digest::HMAC_MD5 qw(hmac_md5);
# TODO: complete qop support in server, should be configurable
$VERSION = "2.14";
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
noplaintext => 1,
noanonymous => 1,
);
# some have to be quoted - some don't - sigh!
my (%cqdval, %sqdval);
@cqdval{qw(
username authzid realm nonce cnonce digest-uri
)} = ();
## ...and server behaves different than client - double sigh!
@sqdval{keys %cqdval, qw(qop cipher)} = ();
# username authzid realm nonce cnonce digest-uri qop cipher
#)} = ();
my %multi;
@{$multi{server}}{qw(realm auth-param)} = ();
@{$multi{client}}{qw()} = ();
my @server_required = qw(algorithm nonce);
my @client_required = qw(username nonce cnonce nc qop response);
# available ciphers
my @ourciphers = (
{
name => 'rc4',
ssf => 128,
bs => 1,
ks => 16,
pkg => 'Crypt::RC4',
key => sub { $_[0] },
iv => sub {},
fixup => sub {
# retrofit the Crypt::RC4 module with standard subs
*Crypt::RC4::encrypt = *Crypt::RC4::decrypt =
sub { goto &Crypt::RC4::RC4; };
*Crypt::RC4::keysize = sub {128};
*Crypt::RC4::blocksize = sub {1};
}
},
{
name => '3des',
ssf => 112,
bs => 8,
ks => 16,
pkg => 'Crypt::DES3',
key => sub {
pack('B8' x 16,
map { $_ . '0' }
map { unpack('a7' x 16, $_); }
unpack('B*', substr($_[0], 0, 14)) );
},
iv => sub { substr($_[0], -8, 8) },
},
{
name => 'des',
ssf => 56,
bs => 8,
ks => 16,
pkg => 'Crypt::DES',
key => sub {
pack('B8' x 8,
map { $_ . '0' }
map { unpack('a7' x 8, $_); }
unpack('B*',substr($_[0], 0, 7)) );
},
iv => sub { substr($_[0], -8, 8) },
},
{
name => 'rc4-56',
ssf => 56,
bs => 1,
ks => 7,
pkg => 'Crypt::RC4',
key => sub { $_[0] },
iv => sub {},
fixup => sub {
*Crypt::RC4::encrypt = *Crypt::RC4::decrypt =
sub { goto &Crypt::RC4::RC4; };
*Crypt::RC4::keysize = sub {56};
*Crypt::RC4::blocksize = sub {1};
}
},
{
name => 'rc4-40',
ssf => 40,
bs => 1,
ks => 5,
pkg => 'Crypt::RC4',
key => sub { $_[0] },
iv => sub {},
fixup => sub {
*Crypt::RC4::encrypt = *Crypt::RC4::decrypt =
sub { goto &Crypt::RC4::RC4; };
*Crypt::RC4::keysize = sub {40};
*Crypt::RC4::blocksize = sub {1};
}
},
);
## The system we are on, might not be able to crypt the stream
our $NO_CRYPT_AVAILABLE = 1;
for (@ourciphers) {
eval "require $_->{pkg}";
unless ($@) {
$NO_CRYPT_AVAILABLE = 0;
last;
}
}
sub _order { 3 }
sub _secflags {
shift;
scalar grep { $secflags{$_} } @_;
}
sub mechanism { 'DIGEST-MD5' }
sub _init {
my ($pkg, $self) = @_;
bless $self, $pkg;
# set default security properties
$self->property('minssf', 0);
$self->property('maxssf', int 2**31 - 1); # XXX - arbitrary "high" value
$self->property('maxbuf', 0xFFFFFF); # maximum supported by GSSAPI mech
$self->property('externalssf', 0);
$self;
}
sub _init_server {
my $server = shift;
my $options = shift || {};
if (!ref $options or ref $options ne 'HASH') {
warn "options for DIGEST_MD5 should be a hashref";
$options = {};
}
## new server, means new nonce_counts
$server->{nonce_counts} = {};
## determine supported qop
my @qop = ('auth');
push @qop, 'auth-int' unless $options->{no_integrity};
push @qop, 'auth-conf' unless $options->{no_integrity}
or $options->{no_confidentiality}
or $NO_CRYPT_AVAILABLE;
$server->{supported_qop} = { map { $_ => 1 } @qop };
}
sub init_sec_layer {
my $self = shift;
$self->{cipher} = undef;
$self->{khc} = undef;
$self->{khs} = undef;
$self->{sndseqnum} = 0;
$self->{rcvseqnum} = 0;
# reset properties for new session
$self->property(maxout => undef);
$self->property(ssf => undef);
}
# no initial value passed to the server
sub client_start {
my $self = shift;
$self->{need_step} = 1;
$self->{error} = undef;
$self->{state} = 0;
$self->init_sec_layer;
'';
}
sub server_start {
my $self = shift;
my $challenge = shift;
my $cb = shift || sub {};
$self->{need_step} = 1;
$self->{error} = undef;
$self->{nonce} = md5_hex($NONCE || join (":", $$, time, rand));
$self->init_sec_layer;
my $qop = [ sort keys %{$self->{supported_qop}} ];
## get the realm using callbacks but default to the host specified
## during the instanciation of the SASL object
my $realm = $self->_call('realm');
$realm ||= $self->host;
my %response = (
nonce => $self->{nonce},
charset => 'utf-8',
algorithm => 'md5-sess',
realm => $realm,
maxbuf => $self->property('maxbuf'),
## IN DRAFT ONLY:
# If this directive is present multiple times the client MUST treat
# it as if it received a single qop directive containing a comma
# separated value from all instances. I.e.,
# 'qop="auth",qop="auth-int"' is the same as 'qop="auth,auth-int"
'qop' => $qop,
'cipher' => [ map { $_->{name} } @ourciphers ],
);
my $final_response = _response(\%response);
$cb->($final_response);
return;
}
sub client_step { # $self, $server_sasl_credentials
my ($self, $challenge) = @_;
$self->{server_params} = \my %sparams;
# Parse response parameters
$self->_parse_challenge(\$challenge, server => $self->{server_params})
or return $self->set_error("Bad challenge: '$challenge'");
if ($self->{state} == 1) {
# check server's `rspauth' response
return $self->set_error("Server did not send rspauth in step 2")
unless ($sparams{rspauth});
return $self->set_error("Invalid rspauth in step 2")
unless ($self->{rspauth} eq $sparams{rspauth});
# all is well
$self->set_success;
return '';
}
# check required fields in server challenge
if (my @missing = grep { !exists $sparams{$_} } @server_required) {
return $self->set_error("Server did not provide required field(s): @missing")
}
my %response = (
nonce => $sparams{'nonce'},
cnonce => md5_hex($CNONCE || join (":", $$, time, rand)),
'digest-uri' => $self->service . '/' . $self->host,
# calc how often the server nonce has been seen; server expects "00000001"
nc => sprintf("%08d", ++$self->{nonce_counts}{$sparams{'nonce'}}),
charset => $sparams{'charset'},
);
return $self->set_error("Server qop too weak (qop = $sparams{'qop'})")
unless ($self->_client_layer(\%sparams,\%response));
# let caller-provided fields override defaults: authorization ID, service name, realm
my $s_realm = $sparams{realm} || [];
my $realm = $self->_call('realm', @$s_realm);
unless (defined $realm) {
# If the user does not pick a realm, use the first from the server
$realm = $s_realm->[0];
}
if (defined $realm) {
$response{realm} = $realm;
}
my $authzid = $self->_call('authname');
if (defined $authzid) {
$response{authzid} = $authzid;
}
my $serv_name = $self->_call('serv');
if (defined $serv_name) {
$response{'digest-uri'} .= '/' . $serv_name;
}
my $user = $self->_call('user');
return $self->set_error("Username is required")
unless defined $user;
$response{username} = $user;
my $password = $self->_call('pass');
return $self->set_error("Password is required")
unless defined $password;
$self->property('maxout', $sparams{maxbuf} || 65536);
# Generate the response value
$self->{state} = 1;
my ($response, $rspauth)
= $self->_compute_digests_and_set_keys($password, \%response);
$response{response} = $response;
$self->{rspauth} = $rspauth;
# finally, return our response token
return _response(\%response, "is_client");
}
sub _compute_digests_and_set_keys {
my $self = shift;
my $password = shift;
my $params = shift;
if (defined $params->{realm} and ref $params->{realm} eq 'ARRAY') {
$params->{realm} = $params->{realm}[0];
}
my $realm = $params->{realm};
$realm = "" unless defined $realm;
my $A1 = join (":",
md5(join (":", $params->{username}, $realm, $password)),
@$params{defined($params->{authzid})
? qw(nonce cnonce authzid)
: qw(nonce cnonce)
}
);
# pre-compute MD5(A1) and HEX(MD5(A1)); these are used multiple times below
my $hdA1 = unpack("H*", (my $dA1 = md5($A1)) );
# derive keys for layer encryption / integrity
$self->{kic} = md5($dA1,
'Digest session key to client-to-server signing key magic constant');
$self->{kis} = md5($dA1,
'Digest session key to server-to-client signing key magic constant');
if (my $cipher = $self->{cipher}) {
&{ $cipher->{fixup} || sub{} };
# compute keys for encryption
my $ks = $cipher->{ks};
$self->{kcc} = md5(substr($dA1,0,$ks),
'Digest H(A1) to client-to-server sealing key magic constant');
$self->{kcs} = md5(substr($dA1,0,$ks),
'Digest H(A1) to server-to-client sealing key magic constant');
# get an encryption and decryption handle for the chosen cipher
$self->{khc} = $cipher->{pkg}->new($cipher->{key}->($self->{kcc}));
$self->{khs} = $cipher->{pkg}->new($cipher->{key}->($self->{kcs}));
# initialize IVs
$self->{ivc} = $cipher->{iv}->($self->{kcc});
$self->{ivs} = $cipher->{iv}->($self->{kcs});
}
my $A2 = "AUTHENTICATE:" . $params->{'digest-uri'};
$A2 .= ":00000000000000000000000000000000" if ($params->{qop} ne 'auth');
my $response = md5_hex(
join (":", $hdA1, @$params{qw(nonce nc cnonce qop)}, md5_hex($A2))
);
# calculate server `rspauth' response, so we can check in step 2
# the only difference here is in the A2 string which from which
# `AUTHENTICATE' is omitted in the calculation of `rspauth'
$A2 = ":" . $params->{'digest-uri'};
$A2 .= ":00000000000000000000000000000000" if ($params->{qop} ne 'auth');
my $rspauth = md5_hex(
join (":", $hdA1, @$params{qw(nonce nc cnonce qop)}, md5_hex($A2))
);
return ($response, $rspauth);
}
sub server_step {
my $self = shift;
my $challenge = shift;
my $cb = shift || sub {};
$self->{client_params} = \my %cparams;
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) {
$self->set_error("Client did not provide required field(s): @missing");
return $cb->();
}
my $count = hex ($cparams{'nc'} || 0);
unless ($count == ++$self->{nonce_counts}{$cparams{nonce}}) {
$self->set_error("nonce-count doesn't match: $count");
return $cb->();
}
my $qop = $cparams{'qop'} || "auth";
unless ($self->is_qop_supported($qop)) {
$self->set_error("Client qop not supported (qop = '$qop')");
return $cb->();
}
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 '') {
$self->set_error("authzid cannot be empty");
return $cb->();
}
my $authzid = $cparams{authzid};
# digest-uri: "Servers SHOULD check that the supplied value is correct.
# This will detect accidental connection to the incorrect server, as well as
# some redirection attacks"
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
$self->set_error("Incorrect digest-uri");
return $cb->();
}
unless (defined $self->callback('getsecret')) {
$self->set_error("a getsecret callback MUST be defined");
$cb->();
return;
}
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);
};
$self->callback('getsecret')->(
$self,
{ user => $username, realm => $realm, authzid => $authzid },
sub { $cb->( $response_check->( shift ) ) },
);
}
sub is_qop_supported {
my $self = shift;
my $qop = shift;
return $self->{supported_qop}{$qop};
}
sub _response {
my $response = shift;
my $is_client = shift;
my @out;
for my $k (sort keys %$response) {
my $is_array = ref $response->{$k} && ref $response->{$k} eq 'ARRAY';
my @values = $is_array ? @{$response->{$k}} : ($response->{$k});
# Per spec, one way of doing it: multiple k=v
#push @out, [$k, $_] for @values;
# other way: comma separated list
push @out, [$k, join (',', @values)];
}
return join (",", map { _qdval($_->[0], $_->[1], $is_client) } @out);
}
sub _parse_challenge {
my $self = shift;
my $challenge_ref = shift;
my $type = shift;
my $params = shift;
while($$challenge_ref =~
s/^(?:\s*,)*\s* # remaining or crap
([\w-]+) # key, eg: qop
=
("([^\\"]+|\\.)*"|[^,]+) # value, eg: auth-conf or "NoNcE"
\s*(?:,\s*)* # remaining
//x) {
my ($k, $v) = ($1,$2);
if ($v =~ /^"(.*)"$/s) {
($v = $1) =~ s/\\(.)/$1/g;
}
if (exists $multi{$type}{$k}) {
my $aref = $params->{$k} ||= [];
push @$aref, $v;
}
elsif (defined $params->{$k}) {
return $self->set_error("Bad challenge: '$$challenge_ref'");
}
else {
$params->{$k} = $v;
}
}
return length $$challenge_ref ? 0 : 1;
}
sub _qdval {
my ($k, $v, $is_client) = @_;
my $qdval = $is_client ? \%cqdval : \%sqdval;
if (!defined $v) {
return;
}
elsif (exists $qdval->{$k}) {
$v =~ s/([\\"])/\\$1/g;
return qq{$k="$v"};
}
return "$k=$v";
}
sub _server_layer {
my ($self, $auth) = @_;
# XXX dupe
# construct our qop mask
my $maxssf = $self->property('maxssf') - $self->property('externalssf');
$maxssf = 0 if ($maxssf < 0);
my $minssf = $self->property('minssf') - $self->property('externalssf');
$minssf = 0 if ($minssf < 0);
return undef if ($maxssf < $minssf); # sanity check
my $ciphers = [ map { $_->{name} } @ourciphers ];
if (( $auth eq 'auth-conf')
and $self->_select_cipher($minssf, $maxssf, $ciphers )) {
$self->property('ssf', $self->{cipher}->{ssf});
return 1;
}
if ($auth eq 'auth-int') {
$self->property('ssf', 1);
return 1;
}
if ($auth eq 'auth') {
$self->property('ssf', 0);
return 1;
}
return undef;
}
sub _client_layer {
my ($self, $sparams, $response) = @_;
# construct server qop mask
# qop in server challenge is optional: if not there "auth" is assumed
my $smask = 0;
map {
m/^auth$/ and $smask |= 1;
m/^auth-int$/ and $smask |= 2;
m/^auth-conf$/ and $smask |= 4;
} split(/,/, $sparams->{qop}||'auth'); # XXX I think we might have a bug here bc. of LWS
# construct our qop mask
my $cmask = 0;
my $maxssf = $self->property('maxssf') - $self->property('externalssf');
$maxssf = 0 if ($maxssf < 0);
my $minssf = $self->property('minssf') - $self->property('externalssf');
$minssf = 0 if ($minssf < 0);
return undef if ($maxssf < $minssf); # sanity check
# ssf values > 1 mean integrity and confidentiality
# ssf == 1 means integrity but no confidentiality
# ssf < 1 means neither integrity nor confidentiality
# no security layer can be had if buffer size is 0
$cmask |= 1 if ($minssf < 1);
$cmask |= 2 if ($minssf <= 1 and $maxssf >= 1);
$cmask |= 4 if ($maxssf > 1);
# find common bits
$cmask &= $smask;
# parse server cipher options
my @sciphers = split(/,/, $sparams->{'cipher-opts'}||$sparams->{cipher}||'');
if (($cmask & 4) and $self->_select_cipher($minssf,$maxssf,\@sciphers)) {
$response->{qop} = 'auth-conf';
$response->{cipher} = $self->{cipher}->{name};
$self->property('ssf', $self->{cipher}->{ssf});
return 1;
}
if ($cmask & 2) {
$response->{qop} = 'auth-int';
$self->property('ssf', 1);
return 1;
}
if ($cmask & 1) {
$response->{qop} = 'auth';
$self->property('ssf', 0);
return 1;
}
return undef;
}
sub _select_cipher {
my ($self, $minssf, $maxssf, $ciphers) = @_;
# compose a subset of candidate ciphers based on ssf and peer list
my @a = map {
my $c = $_;
(grep { $c->{name} eq $_ } @$ciphers and
$c->{ssf} >= $minssf and $c->{ssf} <= $maxssf) ? $_ : ()
} @ourciphers;
# from these, select the first one we can create an instance of
for (@a) {
next unless eval "require $_->{pkg}";
$self->{cipher} = $_;
return 1;
}
return 0;
}
use Digest::HMAC_MD5 qw(hmac_md5);
sub encode { # input: self, plaintext buffer,length (length not used here)
my $self = shift;
my $seqnum = pack('N', $self->{sndseqnum}++);
my $mac = substr(hmac_md5($seqnum . $_[0], $self->{kic}), 0, 10);
# if integrity only, return concatenation of buffer, MAC, TYPE and SEQNUM
return $_[0] . $mac.pack('n',1) . $seqnum unless ($self->{khc});
# must encrypt, block ciphers need padding bytes
my $pad = '';
my $bs = $self->{cipher}->{bs};
if ($bs > 1) {
# padding is added in between BUF and MAC
my $n = $bs - ((length($_[0]) + 10) & ($bs - 1));
$pad = chr($n) x $n;
}
# XXX - for future AES cipher support, the currently used common _crypt()
# function probably wont do; we might to switch to per-cipher routines
# like so:
# return $self->{khc}->encrypt($_[0] . $pad . $mac) . pack('n', 1) . $seqnum;
return $self->_crypt(0, $_[0] . $pad . $mac) . pack('n', 1) . $seqnum;
}
sub decode { # input: self, cipher buffer,length
my ($self, $buf, $len) = @_;
return if ($len <= 16);
# extract TYPE/SEQNUM from end of buffer
my ($type,$seqnum) = unpack('na[4]', substr($buf, -6, 6, ''));
# decrypt remaining buffer, if necessary
if ($self->{khs}) {
# XXX - see remark above in encode() #$buf = $self->{khs}->decrypt($buf);
$buf = $self->_crypt(1, $buf);
}
return unless ($buf);
# extract 10-byte MAC from the end of (decrypted) buffer
my ($mac) = unpack('a[10]', substr($buf, -10, 10, ''));
if ($self->{khs} and $self->{cipher}->{bs} > 1) {
# remove padding
my $n = ord(substr($buf, -1, 1));
substr($buf, -$n, $n, '');
}
# check the MAC
my $check = substr(hmac_md5($seqnum . $buf, $self->{kis}), 0, 10);
return if ($mac ne $check);
return if (unpack('N', $seqnum) != $self->{rcvseqnum});
$self->{rcvseqnum}++;
return $buf;
}
sub _crypt { # input: op(decrypting=1/encrypting=0)), buffer
my ($self,$d) = (shift,shift);
my $bs = $self->{cipher}->{bs};
if ($bs <= 1) {
# stream cipher
return $d ? $self->{khs}->decrypt($_[0]) : $self->{khc}->encrypt($_[0])
}
# the remainder of this sub is for block ciphers
# get current IV
my $piv = \$self->{$d ? 'ivs' : 'ivc'};
my $iv = $$piv;
my $result = join '', map {
my $x = $d
? $iv ^ $self->{khs}->decrypt($_)
: $self->{khc}->encrypt($iv ^ $_);
$iv = $d ? $_ : $x;
$x;
} unpack("a$bs "x(int(length($_[0])/$bs)), $_[0]);
# store current IV
$$piv = $iv;
return $result;
}
1;
__END__
=head1 NAME
Authen::SASL::Perl::DIGEST_MD5 - Digest MD5 Authentication class
=head1 SYNOPSIS
use Authen::SASL qw(Perl);
$sasl = Authen::SASL->new(
mechanism => 'DIGEST-MD5',
callback => {
user => $user,
pass => $pass,
serv => $serv
},
);
=head1 DESCRIPTION
This method implements the client and server parts of the DIGEST-MD5 SASL
algorithm, as described in RFC 2831.
=head2 CALLBACK
The callbacks used are:
=head3 client
=over 4
=item authname
The authorization id to use after successful authentication
=item user
The username to be used in the response
=item pass
The password to be used to compute the response.
=item serv
The service name when authenticating to a replicated service
=item realm
The authentication realm when overriding the server-provided default.
If not given the server-provided value is used.
The callback will be passed the list of realms that the server provided
in the initial response.
=back
=head3 server
=over4
=item realm
The default realm to provide to the client
=item getsecret(username, realm, authzid)
returns the password associated with C<username> and C<realm>
=back
=head2 PROPERTIES
The properties used are:
=over 4
=item maxbuf
The maximum buffer size for receiving cipher text
=item minssf
The minimum SSF value that should be provided by the SASL security layer.
The default is 0
=item maxssf
The maximum SSF value that should be provided by the SASL security layer.
The default is 2**31
=item externalssf
The SSF value provided by an underlying external security layer.
The default is 0
=item ssf
The actual SSF value provided by the SASL security layer after the SASL
authentication phase has been completed. This value is read-only and set
by the implementation after the SASL authentication phase has been completed.
=item maxout
The maximum plaintext buffer size for sending data to the peer.
This value is set by the implementation after the SASL authentication
phase has been completed and a SASL security layer is in effect.
=back
=head1 SEE ALSO
L<Authen::SASL>,
L<Authen::SASL::Perl>
=head1 AUTHORS
Graham Barr, Djamel Boudjerda (NEXOR), Paul Connolly, Julian Onions (NEXOR),
Yann Kerherve.
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap@perl.org>
=head1 COPYRIGHT
Copyright (c) 2003-2009 Graham Barr, Djamel Boudjerda, Paul Connolly,
Julian Onions, Nexor, Peter Marschall and 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

97
Git/usr/share/perl5/vendor_perl/Authen/SASL/Perl/EXTERNAL.pm Normal file
View File

@ -0,0 +1,97 @@
# Copyright (c) 1998-2002 Graham Barr <gbarr@pobox.com> and 2001 Chris Ridd
# <chris.ridd@isode.com>. All rights reserved. This program
# is free software; you can redistribute it and/or modify it under the
# same terms as Perl itself.
package Authen::SASL::Perl::EXTERNAL;
use strict;
use vars qw($VERSION @ISA);
$VERSION = "2.14";
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
noplaintext => 1,
nodictionary => 1,
noanonymous => 1,
);
sub _order { 2 }
sub _secflags {
shift;
grep { $secflags{$_} } @_;
}
sub mechanism { 'EXTERNAL' }
sub client_start {
my $self = shift;
my $v = $self->_call('user');
defined($v) ? $v : ''
}
#sub client_step {
# shift->_call('user');
#}
1;
__END__
=head1 NAME
Authen::SASL::Perl::EXTERNAL - External Authentication class
=head1 SYNOPSIS
use Authen::SASL qw(Perl);
$sasl = Authen::SASL->new(
mechanism => 'EXTERNAL',
callback => {
user => $user
},
);
=head1 DESCRIPTION
This method implements the client part of the EXTERNAL SASL algorithm,
as described in RFC 2222.
=head2 CALLBACK
The callbacks used are:
=over 4
=item user
The username to be used for authentication
=back
=head1 SEE ALSO
L<Authen::SASL>,
L<Authen::SASL::Perl>
=head1 AUTHORS
Software written by Graham Barr <gbarr@pobox.com>,
documentation written by Peter Marschall <peter@adpm.de>.
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap@perl.org>
=head1 COPYRIGHT
Copyright (c) 1998-2004 Graham Barr.
All rights reserved. This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
Documentation Copyright (c) 2004 Peter Marschall.
All rights reserved. This documentation is distributed,
and may be redistributed, under the same terms as Perl itself.
=cut

375
Git/usr/share/perl5/vendor_perl/Authen/SASL/Perl/GSSAPI.pm Normal file
View File

@ -0,0 +1,375 @@
# Copyright (c) 2006 Simon Wilkinson
# All rights reserved. This program is free software; you can redistribute
# it and/or modify it under the same terms as Perl itself.
package Authen::SASL::Perl::GSSAPI;
use strict;
use vars qw($VERSION @ISA);
use GSSAPI;
$VERSION= "0.05";
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
noplaintext => 1,
noanonymous => 1,
);
sub _order { 4 }
sub _secflags {
shift;
scalar grep { $secflags{$_} } @_;
}
sub mechanism { 'GSSAPI' }
sub _init {
my ($pkg, $self) = @_;
bless $self, $pkg;
# set default security properties
$self->property('minssf', 0);
$self->property('maxssf', int 2**31 - 1); # XXX - arbitrary "high" value
$self->property('maxbuf', 0xFFFFFF); # maximum supported by GSSAPI mech
$self->property('externalssf', 0);
# the cyrus sasl library allows only one bit to be set in the
# layer selection mask in the client reply, we default to
# compatibility with that bug
$self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG', 1);
$self;
}
sub client_start {
my $self = shift;
my $status;
my $principal = $self->service.'@'.$self->host;
# GSSAPI::Name->import is the *constructor*,
# storing the new GSSAPI::Name into $target.
# GSSAPI::Name->import is not the standard
# import() method as used in Perl normally
my $target;
$status = GSSAPI::Name->import($target, $principal, gss_nt_service_name)
or return $self->set_error("GSSAPI Error : ".$status);
$self->{gss_name} = $target;
$self->{gss_ctx} = new GSSAPI::Context;
$self->{gss_state} = 0;
$self->{gss_layer} = undef;
my $cred = $self->_call('pass');
$self->{gss_cred} = (ref($cred) && $cred->isa('GSSAPI::Cred')) ? $cred : GSS_C_NO_CREDENTIAL;
$self->{gss_mech} = $self->_call('gssmech') || gss_mech_krb5;
# reset properties for new session
$self->property(maxout => undef);
$self->property(ssf => undef);
return $self->client_step('');
}
sub client_step {
my ($self, $challenge) = @_;
my $debug = $self->{debug};
my $status;
if ($self->{gss_state} == 0) {
my $outtok;
my $inflags = GSS_C_INTEG_FLAG | GSS_C_MUTUAL_FLAG;#todo:set according to ssf props
my $outflags;
$status = $self->{gss_ctx}->init($self->{gss_cred}, $self->{gss_name},
$self->{gss_mech},
$inflags,
0, GSS_C_NO_CHANNEL_BINDINGS, $challenge, undef,
$outtok, $outflags, undef);
print STDERR "state(0): ".
$status->generic_message.';'.$status->specific_message.
"; output token sz: ".length($outtok)."\n"
if ($debug & 1);
if (GSSAPI::Status::GSS_ERROR($status->major)) {
return $self->set_error("GSSAPI Error (init): ".$status);
}
if ($status->major == GSS_S_COMPLETE) {
$self->{gss_state} = 1;
}
return $outtok;
}
elsif ($self->{gss_state} == 1) {
# If the server has an empty output token when it COMPLETEs, Cyrus SASL
# kindly sends us that empty token. We need to ignore it, which introduces
# another round into the process.
print STDERR " state(1): challenge is EMPTY\n"
if ($debug and $challenge eq '');
return '' if ($challenge eq '');
my $unwrapped;
$status = $self->{gss_ctx}->unwrap($challenge, $unwrapped, undef, undef)
or return $self->set_error("GSSAPI Error (unwrap challenge): ".$status);
return $self->set_error("GSSAPI Error : invalid security layer token")
if (length($unwrapped) != 4);
# the security layers the server supports: bitmask of
# 1 = no security layer,
# 2 = integrity protection,
# 4 = confidelity protection
# which is encoded in the first octet of the response;
# the remote maximum buffer size is encoded in the next three octets
#
my $layer = ord(substr($unwrapped, 0, 1, chr(0)));
my ($rsz) = unpack('N',$unwrapped);
# get local receive buffer size
my $lsz = $self->property('maxbuf');
# choose security layer
my $choice = $self->_layer($layer,$rsz,$lsz);
return $self->set_error("GSSAPI Error: security too weak") unless $choice;
$self->{gss_layer} = $choice;
if ($choice > 1) {
# determine maximum plain text message size for peer's cipher buffer
my $psz;
$status = $self->{gss_ctx}->wrap_size_limit($choice & 4, 0, $rsz, $psz)
or return $self->set_error("GSSAPI Error (wrap size): ".$status);
return $self->set_error("GSSAPI wrap size = 0") unless ($psz);
$self->property(maxout => $psz);
# set SSF property; if we have just integrity protection SSF is set
# to 1. If we have confidentiality, SSF would be an estimate of the
# strength of the actual encryption ciphers in use which is not
# available through the GSSAPI interface; for now just set it to
# the lowest value that signifies confidentiality.
$self->property(ssf => (($choice & 4) ? 2 : 1));
} else {
# our advertised buffer size should be 0 if no layer selected
$lsz = 0;
$self->property(ssf => 0);
}
print STDERR "state(1): layermask $layer,rsz $rsz,lsz $lsz,choice $choice\n"
if ($debug & 1);
my $message = pack('CCCC', $choice,
($lsz >> 16)&0xff, ($lsz >> 8)&0xff, $lsz&0xff);
# append authorization identity if we have one
my $authz = $self->_call('authname');
$message .= $authz if ($authz);
my $outtok;
$status = $self->{gss_ctx}->wrap(0, 0, $message, undef, $outtok)
or return $self->set_error("GSSAPI Error (wrap token): ".$status);
$self->{gss_state} = 0;
return $outtok;
}
}
# default layer selection
sub _layer {
my ($self, $theirmask, $rsz, $lsz) = @_;
my $maxssf = $self->property('maxssf') - $self->property('externalssf');
$maxssf = 0 if ($maxssf < 0);
my $minssf = $self->property('minssf') - $self->property('externalssf');
$minssf = 0 if ($minssf < 0);
return undef if ($maxssf < $minssf); # sanity check
# ssf values > 1 mean integrity and confidentiality
# ssf == 1 means integrity but no confidentiality
# ssf < 1 means neither integrity nor confidentiality
# no security layer can be had if buffer size is 0
my $ourmask = 0;
$ourmask |= 1 if ($minssf < 1);
$ourmask |= 2 if ($minssf <= 1 and $maxssf >= 1);
$ourmask |= 4 if ($maxssf > 1);
$ourmask &= 1 unless ($rsz and $lsz);
# mask the bits they dont have
$ourmask &= $theirmask;
return $ourmask unless $self->property('COMPAT_CYRUSLIB_REPLY_MASK_BUG');
# in cyrus sasl bug compat mode, select the highest bit set
return 4 if ($ourmask & 4);
return 2 if ($ourmask & 2);
return 1 if ($ourmask & 1);
return undef;
}
sub encode { # input: self, plaintext buffer,length (length not used here)
my $self = shift;
my $wrapped;
my $status = $self->{gss_ctx}->wrap($self->{gss_layer} & 4, 0, $_[0], undef, $wrapped);
$self->set_error("GSSAPI Error (encode): " . $status), return
unless ($status);
return $wrapped;
}
sub decode { # input: self, cipher buffer,length (length not used here)
my $self = shift;
my $unwrapped;
my $status = $self->{gss_ctx}->unwrap($_[0], $unwrapped, undef, undef);
$self->set_error("GSSAPI Error (decode): " . $status), return
unless ($status);
return $unwrapped;
}
__END__
=head1 NAME
Authen::SASL::Perl::GSSAPI - GSSAPI (Kerberosv5) Authentication class
=head1 SYNOPSIS
use Authen::SASL qw(Perl);
$sasl = Authen::SASL->new( mechanism => 'GSSAPI' );
$sasl = Authen::SASL->new( mechanism => 'GSSAPI',
callback => { pass => $mycred });
$sasl->client_start( $service, $host );
=head1 DESCRIPTION
This method implements the client part of the GSSAPI SASL algorithm,
as described in RFC 2222 section 7.2.1 resp. draft-ietf-sasl-gssapi-XX.txt.
With a valid Kerberos 5 credentials cache (aka TGT) it allows
to connect to I<service>@I<host> given as the first two parameters
to Authen::SASL's client_start() method. Alternatively, a GSSAPI::Cred
object can be passed in via the Authen::SASL callback hash using
the `pass' key.
Please note that this module does not currently implement a SASL
security layer following authentication. Unless the connection is
protected by other means, such as TLS, it will be vulnerable to
man-in-the-middle attacks. If security layers are required, then the
L<Authen::SASL::XS> GSSAPI module should be used instead.
=head2 CALLBACK
The callbacks used are:
=over 4
=item authname
The authorization identity to be used in SASL exchange
=item gssmech
The GSS mechanism to be used in the connection
=item pass
The GSS credentials to be used in the connection (optional)
=back
=head1 EXAMPLE
#! /usr/bin/perl -w
use strict;
use Net::LDAP 0.33;
use Authen::SASL 2.10;
# -------- Adjust to your environment --------
my $adhost = 'theserver.bla.net';
my $ldap_base = 'dc=bla,dc=net';
my $ldap_filter = '(&(sAMAccountName=BLAAGROL))';
my $sasl = Authen::SASL->new(mechanism => 'GSSAPI');
my $ldap;
eval {
$ldap = Net::LDAP->new($adhost,
onerror => 'die')
or die "Cannot connect to LDAP host '$adhost': '$@'";
$ldap->bind(sasl => $sasl);
};
if ($@) {
chomp $@;
die "\nBind error : $@",
"\nDetailed SASL error: ", $sasl->error,
"\nTerminated";
}
print "\nLDAP bind() succeeded, working in authenticated state";
my $mesg = $ldap->search(base => $ldap_base,
filter => $ldap_filter);
# -------- evaluate $mesg
=head2 PROPERTIES
The properties used are:
=over 4
=item maxbuf
The maximum buffer size for receiving cipher text
=item minssf
The minimum SSF value that should be provided by the SASL security layer.
The default is 0
=item maxssf
The maximum SSF value that should be provided by the SASL security layer.
The default is 2**31
=item externalssf
The SSF value provided by an underlying external security layer.
The default is 0
=item ssf
The actual SSF value provided by the SASL security layer after the SASL
authentication phase has been completed. This value is read-only and set
by the implementation after the SASL authentication phase has been completed.
=item maxout
The maximum plaintext buffer size for sending data to the peer.
This value is set by the implementation after the SASL authentication
phase has been completed and a SASL security layer is in effect.
=back
=head1 SEE ALSO
L<Authen::SASL>,
L<Authen::SASL::Perl>
=head1 AUTHORS
Written by Simon Wilkinson, with patches and extensions by Achim Grolms
and Peter Marschall.
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap@perl.org>
=head1 COPYRIGHT
Copyright (c) 2006 Simon Wilkinson, Achim Grolms and Peter Marschall.
All rights reserved. This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
=cut

216
Git/usr/share/perl5/vendor_perl/Authen/SASL/Perl/LOGIN.pm Normal file
View File

@ -0,0 +1,216 @@
# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL::Perl::LOGIN;
use strict;
use vars qw($VERSION @ISA);
$VERSION = "2.14";
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
noanonymous => 1,
);
sub _order { 1 }
sub _secflags {
shift;
scalar grep { $secflags{$_} } @_;
}
sub mechanism { 'LOGIN' }
sub client_start {
my $self = shift;
$self->{stage} = 0;
'';
}
sub client_step {
my ($self, $string) = @_;
# XXX technically this is wrong. I might want to change that.
# spec say it's "staged" and that the content of the challenge doesn't
# matter
# actually, let's try
my $stage = ++$self->{stage};
if ($stage == 1) {
return $self->_call('user');
}
elsif ($stage == 2) {
return $self->_call('pass');
}
elsif ($stage == 3) {
$self->set_success;
return;
}
else {
return $self->set_error("Invalid sequence");
}
}
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;
$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) {
unless (defined $response) {
$self->set_error("Invalid sequence (empty username)");
return $user_cb->();
}
$self->{answer}{user} = $response;
return $user_cb->("Password:");
}
elsif ($stage == 2) {
unless (defined $response) {
$self->set_error("Invalid sequence (empty pass)");
return $user_cb->();
}
$self->{answer}{pass} = $response;
}
else {
$self->set_error("Invalid sequence (end)");
return $user_cb->();
}
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);
}
else {
$self->set_success;
}
$user_cb->();
};
$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->();
}
return;
}
1;
__END__
=head1 NAME
Authen::SASL::Perl::LOGIN - Login Authentication class
=head1 SYNOPSIS
use Authen::SASL qw(Perl);
$sasl = Authen::SASL->new(
mechanism => 'LOGIN',
callback => {
user => $user,
pass => $pass
},
);
=head1 DESCRIPTION
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
The username to be used for authentication
=item pass
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>,
L<Authen::SASL::Perl>
=head1 AUTHORS
Software written by Graham Barr <gbarr@pobox.com>,
documentation written by Peter Marschall <peter@adpm.de>.
Server support by Yann Kerherve <yannk@cpan.org>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap@perl.org>
=head1 COPYRIGHT
Copyright (c) 2002-2004 Graham Barr.
All rights reserved. This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
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

182
Git/usr/share/perl5/vendor_perl/Authen/SASL/Perl/PLAIN.pm Normal file
View File

@ -0,0 +1,182 @@
# Copyright (c) 2002 Graham Barr <gbarr@pobox.com>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
package Authen::SASL::Perl::PLAIN;
use strict;
use vars qw($VERSION @ISA);
$VERSION = "2.14";
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
noanonymous => 1,
);
my @tokens = qw(authname user pass);
sub _order { 1 }
sub _secflags {
shift;
grep { $secflags{$_} } @_;
}
sub mechanism { 'PLAIN' }
sub client_start {
my $self = shift;
$self->{error} = undef;
$self->{need_step} = 0;
my @parts = map {
my $v = $self->_call($_);
defined($v) ? $v : ''
} @tokens;
join("\0", @parts);
}
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")
unless defined $response;
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);
}
else {
$self->set_success;
}
$user_cb->();
};
$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;
}
## error by default
else {
$self->set_error($error);
$user_cb->();
}
}
1;
__END__
=head1 NAME
Authen::SASL::Perl::PLAIN - Plain Login Authentication class
=head1 SYNOPSIS
use Authen::SASL qw(Perl);
$sasl = Authen::SASL->new(
mechanism => 'PLAIN',
callback => {
user => $user,
pass => $pass
},
);
=head1 DESCRIPTION
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
The callbacks used are:
=head3 Client
=over 4
=item authname
The authorization id to use after successful authentication (client)
=item user
The username to be used for authentication (client)
=item pass
The user's password to be used for authentication.
=back
=head3 Server
=over4
=item checkpass(username, password, realm)
returns true and false depending on the validity of the credentials passed
in arguments.
=back
=head1 SEE ALSO
L<Authen::SASL>,
L<Authen::SASL::Perl>
=head1 AUTHORS
Software written by Graham Barr <gbarr@pobox.com>,
documentation written by Peter Marschall <peter@adpm.de>.
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap@perl.org>
=head1 COPYRIGHT
Copyright (c) 2002-2004 Graham Barr.
All rights reserved. This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.
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