KevinSchoenmayer/GseTDDUebungKCLR
2
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Initial Commit

Browse Source
This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions
Download Patch File Download Diff File Expand all files Collapse all files

130
database/perl/vendor/lib/Authen/SASL.pm vendored 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;

241
database/perl/vendor/lib/Authen/SASL.pod vendored Normal file
View File

@@ -0,0 +1,241 @@
=head1 NAME
Authen::SASL - SASL Authentication framework
=head1 SYNOPSIS
use Authen::SASL;
$sasl = Authen::SASL->new(
mechanism => 'CRAM-MD5 PLAIN ANONYMOUS',
callback => {
pass => \&fetch_password,
user => $user,
}
);
=head1 DESCRIPTION
SASL is a generic mechanism for authentication used by several
network protocols. B<Authen::SASL> provides an implementation
framework that all protocols should be able to share.
The framework allows different implementations of the connection
class to be plugged in. At the time of writing there were two such
plugins.
=over 4
=item Authen::SASL::Perl
This module implements several mechanisms and is implemented
entirely in Perl.
=item Authen::SASL::XS
This module uses the Cyrus SASL C-library (both version 1 and 2
are supported).
=item Authen::SASL::Cyrus
This module is the predecessor to L<Authen::SASL::XS>. It is reccomended
to use L<Authen::SASL::XS>
=back
By default the order in which these plugins are selected is
Authen::SASL::XS, Authen::SASL::Cyrus and then Authen::SASL::Perl.
If you want to change it or want to specifically use one
implementation only simply do
use Authen::SASL qw(Perl);
or if you have another plugin module that supports the Authen::SASL API
use Authen::SASL qw(My::SASL::Plugin);
=head2 CONTRUCTOR
=over 4
=item new ( OPTIONS )
The constructor may be called with or without arguments. Passing arguments is
just a short cut to calling the C<mechanism> and C<callback> methods.
=over 4
=item callback =E<gt> { NAME => VALUE, NAME => VALUE, ... }
Set the callbacks.
See the L<callback|/callback> method for details.
=item mechanism =E<gt> NAMES
=item mech =E<gt> NAMES
Set the list of mechanisms to choose from.
See the L<mechanism|/mechanism> method for details.
=item debug =E<gt> VALUE
Set the debug level bit-value to C<VALUE>
Debug output will be sent to C<STDERR>. The
bits of this value are:
1 Show debug messages in the Perl modules for the mechanisms.
(Currently only used in GSSAPI)
4 With security layers in place show information on packages read.
8 With security layers in place show information on packages written.
The default value is 0.
=back
=back
=head2 METHODS
=over 4
=item mechanism ( )
Returns the current list of mechanisms
=item mechanism ( NAMES )
Set the list of mechanisms to choose from. C<NAMES> should be a space separated string
of the names.
=item callback ( NAME )
Returns the current callback associated with C<NAME>.
=item callback ( NAME => VALUE, NAME => VALUE, ... )
Sets the given callbacks to the given values
=item client_new ( SERVICE, HOST, SECURITY )
Creates and returns a new connection object for a client-side connection.
=item server_new ( SERVICE, HOST, OPTIONS )
Creates and returns a new connection object for a server-side connection.
=item error ( )
Returns any error from the last connection
=back
=head1 The Connection Class
=over 4
=item server_start ( CHALLENGE )
server_start begins the authentication using the chosen mechanism.
If the mechanism is not supported by the installed SASL it fails.
Because for some mechanisms the client has to start the negotiation,
you can give the client challenge as a parameter.
=item server_step ( CHALLENGE )
server_step performs the next step in the negotiation process. The
first parameter you give is the clients challenge/response.
=item client_start ( )
The initial step to be performed. Returns the initial value to pass to the server
or an empty list on error.
=item client_step ( CHALLENGE )
This method is called when a response from the server requires it. CHALLENGE
is the value from the server. Returns the next value to pass to the server or an
empty list on error.
=item need_step ( )
Returns true if the selected mechanism requires another step before completion
(error or success).
=item answer ( NAME )
The method will return the value returned from the last call to the callback NAME
=item property ( NAME )
Returns the property value associated with C<NAME>.
=item property ( NAME => VALUE, NAME => VALUE, ... )
Sets the named properties to their associated values.
=item service ( )
Returns the service argument that was passed to *_new-methods.
=item host ( )
Returns the host argument that was passed to *_new-methods.
=item mechanism ( )
Returns the name of the chosen mechanism.
=item is_success ( )
Once need_step() returns false, then you can check if the authentication
succeeded by calling this method which returns a boolean value.
=back
=head2 Callbacks
There are three different ways in which a callback may be passed
=over
=item CODEREF
If the value passed is a code reference then, when needed, it will be called
and the connection object will be passed as the first argument. In addition
some callbacks may be passed additional arguments.
=item ARRAYREF
If the value passed is an array reference, the first element in the array
must be a code reference. When the callback is called the code reference
will be called with the connection object passed as the first argument
and all other values from the array passed after.
=item SCALAR
All other values passed will be used directly. ie it is the same as
passing an code reference that, when called, returns the value.
=back
=head1 SEE ALSO
L<Authen::SASL::Perl>, L<Authen::SASL::XS>, L<Authen::SASL::Cyrus>
=head1 AUTHOR
Graham Barr <gbarr@pobox.com>
Please report any bugs, or post any suggestions, to the perl-ldap mailing list
<perl-ldap@perl.org>
=head1 COPYRIGHT
Copyright (c) 1998-2005 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.
=cut

18
database/perl/vendor/lib/Authen/SASL/CRAM_MD5.pm vendored 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
database/perl/vendor/lib/Authen/SASL/EXTERNAL.pm vendored 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
database/perl/vendor/lib/Authen/SASL/Perl.pm vendored 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;

154
database/perl/vendor/lib/Authen/SASL/Perl.pod vendored Normal file
View File

@@ -0,0 +1,154 @@
# Copyright (c) 2004 Peter Marschall <peter@adpm.de>. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.
=head1 NAME
Authen::SASL::Perl -- Perl implementation of the SASL Authentication framework
=head1 SYNOPSIS
use Authen::SASL qw(Perl);
$sasl = Authen::SASL->new(
mechanism => 'CRAM-MD5 PLAIN ANONYMOUS',
callback => {
user => $user,
pass => \&fetch_password
}
);
=head1 DESCRIPTION
B<Authen::SASL::Perl> is the pure Perl implementation of SASL mechanisms
in the B<Authen::SASL> framework.
At the time of this writing it provides the client part implementation
for the following SASL mechanisms:
=over 4
=item ANONYMOUS
The Anonymous SASL Mechanism as defined in RFC 2245 resp.
in IETF Draft draft-ietf-sasl-anon-03.txt from February 2004
provides a method to anonymously access internet services.
Since it does no authentication it does not need to send
any confidential information such as passwords in plain text
over the network.
=item CRAM-MD5
The CRAM-MD5 SASL Mechanism as defined in RFC2195 resp.
in IETF Draft draft-ietf-sasl-crammd5-XX.txt
offers a simple challenge-response authentication mechanism.
Since it is a challenge-response authentication mechanism
no passwords are transferred in clear-text over the wire.
Due to the simplicity of the protocol CRAM-MD5 is susceptible
to replay and dictionary attacks, so DIGEST-MD5 should be used
in preferrence.
=item DIGEST-MD5
The DIGEST-MD5 SASL Mechanism as defined in RFC 2831 resp.
in IETF Draft draft-ietf-sasl-rfc2831bis-XX.txt
offers the HTTP Digest Access Authentication as SASL mechanism.
Like CRAM-MD5 it is a challenge-response authentication
method that does not send plain text passwords over the network.
Compared to CRAM-MD5, DIGEST-MD5 prevents chosen plaintext
attacks, and permits the use of third party authentication servers,
so that it is recommended to use DIGEST-MD5 instead of CRAM-MD5
when possible.
=item EXTERNAL
The EXTERNAL SASL mechanism as defined in RFC 2222
allows the use of external authentication systems as SASL mechanisms.
=item GSSAPI
The GSSAPI SASL mechanism as defined in RFC 2222 resp. IETF Draft
draft-ietf-sasl-gssapi-XX.txt allows using the Generic Security Service
Application Program Interface [GSSAPI] KERBEROS V5 as as SASL mechanism.
Although GSSAPI is a general mechanism for authentication it is almost
exlusively used for Kerberos 5.
=item LOGIN
The LOGIN SASL Mechanism as defined in IETF Draft
draft-murchison-sasl-login-XX.txt allows the
combination of username and clear-text password to be used
in a SASL mechanism.
It does does not provide a security layer and sends the credentials
in clear over the wire.
Thus this mechanism should not be used without adequate security
protection.
=item PLAIN
The Plain SASL Mechanism as defined in RFC 2595 resp. IETF Draft
draft-ietf-sasl-plain-XX.txt is another SASL mechanism that allows
username and clear-text password combinations in SASL environments.
Like LOGIN it sends the credentials in clear over the network
and should not be used without sufficient security protection.
=back
As for server support, only I<PLAIN>, I<LOGIN> and I<DIGEST-MD5> are supported
at the time of this writing.
C<server_new> OPTIONS is a hashref that is only relevant for I<DIGEST-MD5> for
now and it supports the following options:
=over 4
=item - no_integrity
=item - no_confidentiality
=back
which configures how the security layers are negotiated with the client (or
rather imposed to the client).
=head1 SEE ALSO
L<Authen::SASL>,
L<Authen::SASL::Perl::ANONYMOUS>,
L<Authen::SASL::Perl::CRAM_MD5>,
L<Authen::SASL::Perl::DIGEST_MD5>,
L<Authen::SASL::Perl::EXTERNAL>,
L<Authen::SASL::Perl::GSSAPI>,
L<Authen::SASL::Perl::LOGIN>,
L<Authen::SASL::Perl::PLAIN>
=head1 AUTHOR
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) 2004-2006 Peter Marschall.
All rights reserved. This document is distributed, and may be redistributed,
under the same terms as Perl itself.
=cut

93
database/perl/vendor/lib/Authen/SASL/Perl/ANONYMOUS.pm vendored 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
database/perl/vendor/lib/Authen/SASL/Perl/CRAM_MD5.pm vendored 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
database/perl/vendor/lib/Authen/SASL/Perl/DIGEST_MD5.pm vendored 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
database/perl/vendor/lib/Authen/SASL/Perl/EXTERNAL.pm vendored 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
database/perl/vendor/lib/Authen/SASL/Perl/GSSAPI.pm vendored 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
database/perl/vendor/lib/Authen/SASL/Perl/LOGIN.pm vendored 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
database/perl/vendor/lib/Authen/SASL/Perl/PLAIN.pm vendored 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