Message Digest Authentication
Doug MacEachern (dougm@osf.org)
Sun, 10 Mar 1996 15:39:22 -0500
Here's two patches for LWP::UserAgent and lwp-request to support message
digest authentication. The patches are against the latest b9 release.
It is based on NCSA's implementation and the Digest Access Authentication
internet-draft. It requires Neil Winston's MD5 module version 1.4, there's
a new release too (1.5.1), but I haven't looked at it yet. It doesn't check
for the optional 'Digest-MessageDigest' header from the server. But, as far
as I know, NCSA is the only server that supports digest auth, and it doesn't
seem to send it, so I think it can wait. It could also use some code so
it's smart enough to send Authorization if it has it for the current netloc,
realm and uri, before the server sends a 401.
You can test it out with GET http://www.osf.org/~dougm/test/
username test
password 14md5
Enjoy,
-Doug
*** UserAgent.pm.dist Sun Mar 10 14:15:35 1996
--- UserAgent.pm Sun Mar 10 14:56:10 1996
***************
*** 305,310 ****
--- 305,373 ----
} else {
return $response; # no password found
}
+ } elsif ($scheme =~ /^Digest$/i) {
+ #http://hopf.math.nwu.edu/digestauth/draft.rfc
+ require MD5;
+ my $md5 = new MD5;
+ my($uid, $pwd) = $self->get_digest_credentials($realm,
+ $request->url);
+ my $string = $challenge;
+ $string =~ s/^$scheme\s+//; $string =~ s/"//g;
+ my(%mda) = map { split(/,?\s+|=/) } $string;
+
+ my(@digest);
+ $md5->add(join(":", $uid,$mda{realm},$pwd));
+ push(@digest, $md5->hexdigest);
+ $md5->reset;
+
+ push(@digest, $mda{nonce});
+
+ $md5->add(join(":",$request->method,$request->url->path));
+ push(@digest, $md5->hexdigest);
+ $md5->reset;
+
+ $md5->add(join(":", @digest));
+ my($digest) = $md5->hexdigest;
+ $md5->reset;
+
+ my(%resp) = map { $_, $mda{$_} } qw(realm nonce opaque);
+ @resp{qw(username uri response)} = ($uid,
$request->url->path, $digest);
+
+ if (defined $uid and defined $pwd) {
+ my(@order) = qw(username realm nonce uri response);
+ if($request->method =~ /^POST|PUT$/) {
+ $md5->add($request->content);
+ my($content) = $md5->hexdigest;
+ $md5->reset;
+ $md5->add(join(":", @digest[0..1], $content));
+ $md5->reset;
+ $resp{"message-digest"} = $md5->hexdigest;
+ push(@order, "message-digest");
+ }
+ push(@order, "opaque");
+ my(@pairs) = map { "$_=" . qq("$resp{$_}") } @order;
+ my $header = "$scheme " . join(", ", @pairs);
+
+ # Need to check this isn't a repeated fail!
+ my $r = $response;
+ while ($r) {
+ my $auth = $r->request->header('Authorization');
+ if ($auth && $auth eq $header) {
+ # here we know this failed before
+ $response->message('Invalid Credentials');
+ return $response;
+ }
+ $r = $r->previous;
+ }
+
+ my $referral = $request->clone;
+ $referral->header('Extension', "Security/Digest");
+ $referral->header('Authorization', $header);
+
+ return $self->request($referral, $arg, $size, $response);
+ } else {
+ return $response; # no password found
+ }
} else {
warn "Authentication scheme '$scheme' not supported\n";
return $response;
***************
*** 349,356 ****
=head2 $ua->credentials($netloc, $realm, $uname, $pass)
! Set the user name and password to be used for a realm. If is often
! more useful to specialize the credentials() method instead.
=cut
--- 412,419 ----
=head2 $ua->credentials($netloc, $realm, $uname, $pass)
! Set the user name and password to be used for a realm protected by Basic
Authentication.
! If is often more useful to specialize the credentials() method instead.
=cut
***************
*** 360,366 ****
--- 423,442 ----
@{ $self->{'basic_authentication'}{$netloc}{$realm} } = ($uid, $pass);
}
+ =head2 $ua->digest_credentials($netloc, $realm, $uname, $pass)
+ Set the user name and password to be used for a realm protected by
+ Message Digest Authentication. If is often more useful to specialize
+ the digest_credentials() method instead.
+
+ =cut
+
+ sub digest_credentials
+ {
+ my($self, $netloc, $realm, $uid, $pass) = @_;
+ @{ $self->{'digest_authentication'}{$netloc}{$realm} } = ($uid, $pass);
+ }
+
=head2 get_basic_credentials($realm, $uri)
This is called by request() to retrieve credentials for a Realm
***************
*** 388,393 ****
--- 464,495 ----
return (undef, undef);
}
+ =head2 get_digest_credentials($realm, $uri)
+
+ This is called by request() to retrieve credentials for a Realm
+ protected by Digest Authentication.
+
+ Should return username and password in a list. Return undef to abort
+ the authentication resolution atempts.
+
+ This implementation simply checks a set of pre-stored member
+ variables. Subclasses can override this method to e.g. ask the user
+ for a username/password. An example of this can be found in
+ C<request> program distributed with this library.
+
+ =cut
+
+ sub get_digest_credentials
+ {
+ my($self, $realm, $uri) = @_;
+ my $netloc = $uri->netloc;
+
+ if (exists $self->{'digest_authentication'}{$netloc}{$realm}) {
+ return @{ $self->{'digest_authentication'}{$netloc}{$realm} };
+ }
+
+ return (undef, undef);
+ }
=head2 timeout()
----8<---------------------------------------------------------------
*** lwp-request.dist Sun Mar 10 15:13:25 1996
--- lwp-request Sun Mar 10 15:14:15 1996
***************
*** 233,238 ****
--- 233,243 ----
return (undef, undef)
}
}
+
+ #*get_digest_credentials = \&get_basic_credentials; #gives a warning
+ sub get_digest_credentials {
+ shift->get_basic_credentials(@_);
+ }
}
$method = uc($0 eq "lwp-request" ? "GET" : $0);