Package: libauthen-sasl-perl
Version: 2.09-0pm2
Severity: normal
Tags: patch
Hi,
although DIGEST-MD5 support in Authen::SASL 2.09 is improved compared to
Authen::SASL 2.08 in Debian there is still room for improvement.
The attached patch from Authen::SASL's SVN repository fixes a bug that
slipped into Authen::SASL 2.09, adds better checks and adds a few
callback option to DIGEST-MD5.
Please update libauthen-sasl-perl !
Peter
-- System Information:
Debian Release: testing/unstable
APT prefers testing
APT policy: (990, 'testing'), (500, 'unstable'), (500, 'stable')
Architecture: i386 (i686)
Shell: /bin/sh linked to /bin/bash
Kernel: Linux 2.6.12-1-k7
Locale: LANG=de_DE.UTF-8, LC_CTYPE=de_DE.UTF-8 (charmap=UTF-8)
Versions of packages libauthen-sasl-perl depends on:
ii perl 5.8.7-3 Larry Wall's Practical Extraction
libauthen-sasl-perl recommends no packages.
-- no debconf information
--- lib/Authen/SASL/Perl/DIGEST_MD5.pm 2005-04-26 15:34:23.000000000 +0200
+++ lib/Authen/SASL/Perl/DIGEST_MD5.pm 2005-08-11 14:14:02.000000000 +0200
@@ -1,4 +1,4 @@
-# Copyright (c) 2003 Graham Barr, Djamel Boudjerda, Paul Connolly, Julian
Onions and Nexor.
+# Copyright (c) 2003-2005 Graham Barr, Djamel Boudjerda, Paul Connolly, Julian
Onions and Nexor.
# All rights reserved. This program is free software; you can redistribute
# it and/or modify it under the same terms as Perl itself.
@@ -10,7 +10,7 @@
use vars qw($VERSION @ISA $CNONCE);
use Digest::MD5 qw(md5_hex md5);
-$VERSION = "1.04";
+$VERSION = "1.05";
@ISA = qw(Authen::SASL::Perl);
my %secflags = (
@@ -21,6 +21,9 @@
# some have to be quoted - some don't - sigh!
my %qdval; @qdval{qw(username authzid realm nonce cnonce digest-uri)} = ();
+my %multi; @multi{qw(realm auth-param)} = ();
+my @required = qw(algorithm nonce);
+
sub _order { 3 }
sub _secflags {
shift;
@@ -43,29 +46,54 @@
while($challenge =~ s/^(?:\s*,)?\s*(\w+)=("([^\\"]+|\\.)*"|[^,]+)\s*//) {
my ($k, $v) = ($1,$2);
if ($v =~ /^"(.*)"$/s) {
- ($v = $1) =~ s/\\//g;
+ ($v = $1) =~ s/\\(.)/$1/g;
+ }
+ if (exists $multi{$k}) {
+ my $aref = $sparams{$k} ||= [];
+ push @$aref, $v;
+ }
+ elsif (defined $sparams{$k}) {
+ return $self->set_error("Bad challenge: '$challenge'");
+ }
+ else {
+ $sparams{$k} = $v;
}
- $sparams{$k} = $v;
}
return $self->set_error("Bad challenge: '$challenge'")
if length $challenge;
+ # qop in server challenge is optional: if not there "auth" is assumed
return $self->set_error("Server does not support auth (qop =
$sparams{'qop'})")
- unless grep { /^auth$/ } split(/,/, $sparams{'qop'});
+ if ($sparams{qop} && ! grep { /^auth$/ } split(/,/, $sparams{'qop'}));
+
+ # check required fields in server challenge
+ if (my @missing = grep { !exists $sparams{$_} } @required) {
+ return $self->set_error("Server did not provide required field(s):
@missing")
+ }
my %response = (
nonce => $sparams{'nonce'},
- username => $self->_call('user'),
- realm => $sparams{'realm'},
- nonce => $sparams{'nonce'},
cnonce => md5_hex($CNONCE || join (":", $$, time, rand)),
'digest-uri' => $self->service . '/' . $self->host,
- qop => 'auth',
+ qop => 'auth', # we currently support 'auth' only
+ # calc how often the server nonce has been seen; server expects "00000001"
nc => sprintf("%08d", ++$self->{nonce}{$sparams{'nonce'}}),
charset => $sparams{'charset'},
);
+ # 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;
@@ -73,15 +101,23 @@
my $serv_name = $self->_call('serv');
if (defined $serv_name) {
- $response{'digest_uri'} .= '/' . $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;
# Generate the response value
+ $realm = "" unless defined $realm;
my $A1 = join (":",
- md5(join (":", @response{qw(username realm)}, $password)),
+ md5(join (":", $user, $realm, $password)),
@response{defined($authzid) ? qw(nonce cnonce authzid) : qw(nonce cnonce)}
);
@@ -162,6 +198,11 @@
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.
+
=back
=head1 SEE ALSO
@@ -178,8 +219,8 @@
=head1 COPYRIGHT
-Copyright (c) 2003 Graham Barr, Djamel Boudjerda, Paul Connolly, Julian Onions
-and Nexor.
+Copyright (c) 2003-2005 Graham Barr, Djamel Boudjerda, Paul Connolly,
+Julian Onions, Nexor 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.
--- lib/Authen/SASL/Perl.pm 2005-04-26 15:34:23.000000000 +0200
+++ lib/Authen/SASL/Perl.pm 2005-08-11 14:14:02.000000000 +0200
@@ -90,20 +90,36 @@
}
sub _call {
- my ($self, $name) = @_;
+ 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;
- return $cb->($self, @args);
+ $value = $cb->($self, @args);
}
elsif (ref($cb) eq 'CODE') {
- return $cb->($self);
+ $value = $cb->($self, @_);
+ }
+ else {
+ $value = $cb;
}
- return $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 }
