package LWP::Authen::digest;
use strict;
# Based on <draft-ietf-http-authentication-01>
require MD5;
sub authenticate
{
my($class, $req, $res, $proxy, $auth_param) = @_;
return if $auth_param->{algorithm} &&
$auth_param->{algorithm} !~ /^MD5(-sess)?$/;
if ($auth_param->{stale} && uc($auth_param->{stale}) eq "TRUE") {
# XXX need a reference to the current $auth object so that
# we can update it with the new nonce and don't have to
# ask the user for a username/password again.
$res->push_header("Client-Warning",
"Stale nonce, should use '$auth_param->{nonce}'");
}
my($user, $pass);
($user, $pass) = $req->login($auth_param->{realm},
$req->url, $proxy);
unless (defined $user and defined $pass) {
$res->push_header("Client-Warning", "No username or password given");
return "ABORT";
}
return $class->new(%$auth_param,
username => $user,
password => $pass,
);
}
sub new
{
my $class = shift;
my $self = bless { @_ }, $class;
$self;
}
sub _set_authorization
{
my($self, $header, $req) = @_;
my $user = $self->{username};
return unless defined $user;
my $pass = $self->{password};
my $realm = $self->{realm};
$realm = "" unless defined $realm;
my $algorithm = lc($self->{algorithm} || "md5");
my %qops = map {$_ => 1} split(/\s*,\s*/, lc($self->{qop} || ""));
my $qop = "";
if ($req->has_content && $qops{'auth-int'}) {
$qop = "auth-int";
} elsif ($qops{auth}) {
$qop = "auth";
}
my $uri = $req->uri->path_query;
my $nonce = $self->{nonce}; $nonce = "" unless defined $nonce;
my $nc = sprintf "%08x", ++$self->{nonce_count};
my $cnonce = sprintf "%x", rand(0xFFFFFF)+1; # +1 ensures always TRUE
my $a1;
if ($algorithm eq "md5") {
# A1 = unq(username-value) ":" unq(realm-value) ":" passwd
$a1 = MD5->hexhash("$user:$realm:$pass");
} elsif ($algorithm eq "md5-sess") {
# The following A1 value should only be computed once
$a1 = $self->{'A1'};
unless ($a1) {
# A1 = H( unq(username-value) ":" unq(realm-value) ":" passwd )
# ":" unq(nonce-value) ":" unq(cnonce-value)
$a1 = MD5->hexhash("$user:$realm:$pass") . ":$nonce:$cnonce";
$a1 = MD5->hexhash($a1);
$self->{'A1'} = $a1;
}
} else {
return;
}
my $a2 = $req->method . ":" . $uri;
$a2 .= MD5->hexhash($req->content) if $qop eq "auth-int";
$a2 = MD5->hexhash($a2);
# at this point $a1 is really H(A1) and $a2 is H(A2)
my $response;
if ($qop eq "auth" || $qop eq "auth-int") {
# KD(H(A1), unq(nonce-value)
# :" nc-value
# ":" unq(cnonce-value)
# ":" unq(qop-value)
# ":" H(A2)
# )
$response = MD5->hexhash("$a1:$nonce:$nc:$cnonce:$qop:$a2");
} else {
# compatibility with RFC 2069
# KD ( H(A1), unq(nonce-value) ":" H(A2) )
$response = MD5->hexhash("$a1:$nonce:$a2");
undef($cnonce);
}
my @h;
push(@h, ["username" => $user],
["realm" => $realm],
["nonce" => $nonce],
["uri" => $uri],
["response" => $response]);
push(@h, ["_algorithm" => $self->{algorithm}]) if $self->{algorithm};
push(@h, ["cnonce" => $cnonce]) if $cnonce;
push(@h, ["opaque" => $self->{opaque}]) if exists $self->{opaque};
if ($self->{qop}) {
push(@h, ["_qop" => $qop]);
push(@h, ["_nc" => $nc]);
}
my $h = "Digest " . join(", ",
map {
my($k,$v) = @$_;
unless ($k =~ s/^_//) {
$v =~ s/([\\\"])/\\$1/g;
$v = qq("$v");
}
"$k=$v";
} @h);
$req->header($header => $h);
}
sub set_authorization
{
shift->_set_authorization("Authorization", @_);
}
sub set_proxy_authorization
{
shift->_set_authorization("Proxy-Authorization", @_);
}
sub login
{
my $self = shift;
my @old = ($self->{username}, $self->{password});
if (@_) {
my $user = shift;
unless (defined $user) {
delete $self->{username};
delete $self->{password};
} else {
$self->{username} = $user;
my $pass = shift;
$pass = "" unless defined $pass;
$self->{password} = $pass;
}
}
wantarray ? @old : \@old;
}
sub nonce
{
my $self = shift;
my $old = $self->{'nonce'};
if (@_) {
$self->{'nonce'} = shift;
delete $self->{'nonce_count'};
}
$old;
}
package HTTP::Message;
sub has_content
{
my $self = shift;
return 0 unless defined($self->{_content});
return undef if ref($self->{_content});
return length $self->{_content};
}
1;