fix: auth-header of Digest auth did not conform to RFC 2617 when WWW-…

…Authenticate has 'qop' parameter.
libwww-perl · Mar 11, 2013 · 36c342a · 36c342a
1 parent b192179
commit 36c342a
Show file tree

Hide file tree

Showing 2 changed files with 81 additions and 2 deletions.
diff --git a/lib/LWP/Authen/Digest.pm b/lib/LWP/Authen/Digest.pm
@@ -58,7 +58,14 @@ sub auth_header {
     my @pairs;
     for (@order) {
 	next unless defined $resp{$_};
-	push(@pairs, "$_=" . qq("$resp{$_}"));
+
+	# RFC2617 sais that qop-value and nc-value should be unquoted.
+	if ( $_ eq 'qop' || $_ eq 'nc' ) {
+		push(@pairs, "$_=" . $resp{$_});
+	}
+	else {
+		push(@pairs, "$_=" . qq("$resp{$_}"));
+	}
     }
 
     my $auth_value  = "Digest " . join(", ", @pairs);

diff --git a/t/local/http.t b/t/local/http.t
@@ -50,7 +50,7 @@ else {
 }
 
 use Test::More;
-plan tests => 59;
+plan tests => 63;
 
 my $greeting = <DAEMON>;
 $greeting =~ /(<[^>]+>)/;
@@ -318,6 +318,78 @@ $res = $ua->request($req);
 is($res->code, 401, 'response code 401');
 
 
+#----------------------------------------------------------------
+print "Check digest authorization...\n";
+sub httpd_get_digest
+{
+	my($c, $r) = @_;
+#    print STDERR $r->as_string;
+	my $auth = $r->authorization;
+	my %auth_params;
+	if ( defined($auth) && $auth =~ /^Digest\s+(.*)$/ ) {
+		%auth_params = map { split /=/ } split /,\s*/, $1;
+	}
+	if ( %auth_params &&
+			$auth_params{username} eq "\"ok 23\"" &&
+			$auth_params{realm} eq "\"libwww-perl-digest\"" &&
+			$auth_params{qop} eq "auth" &&
+			$auth_params{algorithm} eq "\"MD5\"" &&
+			$auth_params{uri} eq "\"/digest\"" &&
+			$auth_params{nonce} eq "\"12345\"" &&
+			$auth_params{nc} eq "00000001" &&
+			defined($auth_params{cnonce}) &&
+			defined($auth_params{response})
+		 ) {
+		$c->send_basic_header(200);
+		print $c "Content-Type: text/plain";
+		$c->send_crlf;
+		$c->send_crlf;
+		$c->print("ok\n");
+	}
+	else {
+		$c->send_basic_header(401);
+		$c->print("WWW-Authenticate: Digest realm=\"libwww-perl-digest\", nonce=\"12345\", qop=auth\015\012");
+		$c->send_crlf;
+	}
+}
+
+{
+	package MyUA2; @ISA=qw(LWP::UserAgent);
+	sub get_basic_credentials {
+		my($self, $realm, $uri, $proxy) = @_;
+		if ($realm eq "libwww-perl-digest" && $uri->rel($base) eq "digest") {
+			return ("ok 23", "xyzzy");
+		}
+		else {
+			return undef;
+		}
+	}
+}
+$req = new HTTP::Request GET => url("/digest", $base);
+$res = MyUA2->new->request($req);
+#print STDERR $res->as_string;
+
+ok($res->is_success);
+#print $res->content;
+
+# Let's try with a $ua that does not pass out credentials
+$ua->{basic_authentication}=undef;
+$res = $ua->request($req);
+is($res->code, 401, 'respone code 401');
+
+# Let's try to set credentials for this realm
+$ua->credentials($req->uri->host_port, "libwww-perl-digest", "ok 23", "xyzzy");
+$res = $ua->request($req);
+#print STDERR $res->as_string;
+ok($res->is_success);
+
+# Then illegal credentials
+$ua->credentials($req->uri->host_port, "libwww-perl-digest", "user2", "passwd");
+$res = $ua->request($req);
+is($res->code, 401, 'response code 401');
+
+
+
 #----------------------------------------------------------------
 print "Check proxy...\n";
 sub httpd_get_proxy