529 lines
16 KiB
Perl
529 lines
16 KiB
Perl
|
package HTTP::Negotiate;
|
||
|
|
||
|
$VERSION = "6.01";
|
||
|
sub Version { $VERSION; }
|
||
|
|
||
|
require Exporter;
|
||
|
@ISA = qw(Exporter);
|
||
|
@EXPORT = qw(choose);
|
||
|
|
||
|
require HTTP::Headers;
|
||
|
|
||
|
$DEBUG = 0;
|
||
|
|
||
|
sub choose ($;$)
|
||
|
{
|
||
|
my($variants, $request) = @_;
|
||
|
my(%accept);
|
||
|
|
||
|
unless (defined $request) {
|
||
|
# Create a request object from the CGI environment variables
|
||
|
$request = HTTP::Headers->new;
|
||
|
$request->header('Accept', $ENV{HTTP_ACCEPT})
|
||
|
if $ENV{HTTP_ACCEPT};
|
||
|
$request->header('Accept-Charset', $ENV{HTTP_ACCEPT_CHARSET})
|
||
|
if $ENV{HTTP_ACCEPT_CHARSET};
|
||
|
$request->header('Accept-Encoding', $ENV{HTTP_ACCEPT_ENCODING})
|
||
|
if $ENV{HTTP_ACCEPT_ENCODING};
|
||
|
$request->header('Accept-Language', $ENV{HTTP_ACCEPT_LANGUAGE})
|
||
|
if $ENV{HTTP_ACCEPT_LANGUAGE};
|
||
|
}
|
||
|
|
||
|
# Get all Accept values from the request. Build a hash initialized
|
||
|
# like this:
|
||
|
#
|
||
|
# %accept = ( type => { 'audio/*' => { q => 0.2, mbx => 20000 },
|
||
|
# 'audio/basic' => { q => 1 },
|
||
|
# },
|
||
|
# language => { 'no' => { q => 1 },
|
||
|
# }
|
||
|
# );
|
||
|
|
||
|
$request->scan(sub {
|
||
|
my($key, $val) = @_;
|
||
|
|
||
|
my $type;
|
||
|
if ($key =~ s/^Accept-//) {
|
||
|
$type = lc($key);
|
||
|
}
|
||
|
elsif ($key eq "Accept") {
|
||
|
$type = "type";
|
||
|
}
|
||
|
else {
|
||
|
return;
|
||
|
}
|
||
|
|
||
|
$val =~ s/\s+//g;
|
||
|
my $default_q = 1;
|
||
|
for my $name (split(/,/, $val)) {
|
||
|
my(%param, $param);
|
||
|
if ($name =~ s/;(.*)//) {
|
||
|
for $param (split(/;/, $1)) {
|
||
|
my ($pk, $pv) = split(/=/, $param, 2);
|
||
|
$param{lc $pk} = $pv;
|
||
|
}
|
||
|
}
|
||
|
$name = lc $name;
|
||
|
if (defined $param{'q'}) {
|
||
|
$param{'q'} = 1 if $param{'q'} > 1;
|
||
|
$param{'q'} = 0 if $param{'q'} < 0;
|
||
|
}
|
||
|
else {
|
||
|
$param{'q'} = $default_q;
|
||
|
|
||
|
# This makes sure that the first ones are slightly better off
|
||
|
# and therefore more likely to be chosen.
|
||
|
$default_q -= 0.0001;
|
||
|
}
|
||
|
$accept{$type}{$name} = \%param;
|
||
|
}
|
||
|
});
|
||
|
|
||
|
# Check if any of the variants specify a language. We do this
|
||
|
# because it influences how we treat those without (they default to
|
||
|
# 0.5 instead of 1).
|
||
|
my $any_lang = 0;
|
||
|
for $var (@$variants) {
|
||
|
if ($var->[5]) {
|
||
|
$any_lang = 1;
|
||
|
last;
|
||
|
}
|
||
|
}
|
||
|
|
||
|
if ($DEBUG) {
|
||
|
print "Negotiation parameters in the request\n";
|
||
|
for $type (keys %accept) {
|
||
|
print " $type:\n";
|
||
|
for $name (keys %{$accept{$type}}) {
|
||
|
print " $name\n";
|
||
|
for $pv (keys %{$accept{$type}{$name}}) {
|
||
|
print " $pv = $accept{$type}{$name}{$pv}\n";
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
|
||
|
my @Q = (); # This is where we collect the results of the
|
||
|
# quality calculations
|
||
|
|
||
|
# Calculate quality for all the variants that are available.
|
||
|
for (@$variants) {
|
||
|
my($id, $qs, $ct, $enc, $cs, $lang, $bs) = @$_;
|
||
|
$qs = 1 unless defined $qs;
|
||
|
$ct = '' unless defined $ct;
|
||
|
$bs = 0 unless defined $bs;
|
||
|
$lang = lc($lang) if $lang; # lg tags are always case-insensitive
|
||
|
if ($DEBUG) {
|
||
|
print "\nEvaluating $id (ct='$ct')\n";
|
||
|
printf " qs = %.3f\n", $qs;
|
||
|
print " enc = $enc\n" if $enc && !ref($enc);
|
||
|
print " enc = @$enc\n" if $enc && ref($enc);
|
||
|
print " cs = $cs\n" if $cs;
|
||
|
print " lang = $lang\n" if $lang;
|
||
|
print " bs = $bs\n" if $bs;
|
||
|
}
|
||
|
|
||
|
# Calculate encoding quality
|
||
|
my $qe = 1;
|
||
|
# If the variant has no assigned Content-Encoding, or if no
|
||
|
# Accept-Encoding field is present, then the value assigned
|
||
|
# is "qe=1". If *all* of the variant's content encodings
|
||
|
# are listed in the Accept-Encoding field, then the value
|
||
|
# assigned is "qw=1". If *any* of the variant's content
|
||
|
# encodings are not listed in the provided Accept-Encoding
|
||
|
# field, then the value assigned is "qe=0"
|
||
|
if (exists $accept{'encoding'} && $enc) {
|
||
|
my @enc = ref($enc) ? @$enc : ($enc);
|
||
|
for (@enc) {
|
||
|
print "Is encoding $_ accepted? " if $DEBUG;
|
||
|
unless(exists $accept{'encoding'}{$_}) {
|
||
|
print "no\n" if $DEBUG;
|
||
|
$qe = 0;
|
||
|
last;
|
||
|
}
|
||
|
else {
|
||
|
print "yes\n" if $DEBUG;
|
||
|
}
|
||
|
}
|
||
|
}
|
||
|
|
||
|
# Calculate charset quality
|
||
|
my $qc = 1;
|
||
|
# If the variant's media-type has no charset parameter,
|
||
|
# or the variant's charset is US-ASCII, or if no Accept-Charset
|
||
|
# field is present, then the value assigned is "qc=1". If the
|
||
|
# variant's charset is listed in the Accept-Charset field,
|
||
|
# then the value assigned is "qc=1. Otherwise, if the variant's
|
||
|
# charset is not listed in the provided Accept-Encoding field,
|
||
|
# then the value assigned is "qc=0".
|
||
|
if (exists $accept{'charset'} && $cs && $cs ne 'us-ascii' ) {
|
||
|
$qc = 0 unless $accept{'charset'}{$cs};
|
||
|
}
|
||
|
|
||
|
# Calculate language quality
|
||
|
my $ql = 1;
|
||
|
if ($lang && exists $accept{'language'}) {
|
||
|
my @lang = ref($lang) ? @$lang : ($lang);
|
||
|
# If any of the variant's content languages are listed
|
||
|
# in the Accept-Language field, the the value assigned is
|
||
|
# the largest of the "q" parameter values for those language
|
||
|
# tags.
|
||
|
my $q = undef;
|
||
|
for (@lang) {
|
||
|
next unless exists $accept{'language'}{$_};
|
||
|
my $this_q = $accept{'language'}{$_}{'q'};
|
||
|
$q = $this_q unless defined $q;
|
||
|
$q = $this_q if $this_q > $q;
|
||
|
}
|
||
|
if(defined $q) {
|
||
|
$DEBUG and print " -- Exact language match at q=$q\n";
|
||
|
}
|
||
|
else {
|
||
|
# If there was no exact match and at least one of
|
||
|
# the Accept-Language field values is a complete
|
||
|
# subtag prefix of the content language tag(s), then
|
||
|
# the "q" parameter value of the largest matching
|
||
|
# prefix is used.
|
||
|
$DEBUG and print " -- No exact language match\n";
|
||
|
my $selected = undef;
|
||
|
for $al (keys %{ $accept{'language'} }) {
|
||
|
if (index($al, "$lang-") == 0) {
|
||
|
# $lang starting with $al isn't enough, or else
|
||
|
# Accept-Language: hu (Hungarian) would seem
|
||
|
# to accept a document in hup (Hupa)
|
||
|
$DEBUG and print " -- $al ISA $lang\n";
|
||
|
$selected = $al unless defined $selected;
|
||
|
$selected = $al if length($al) > length($selected);
|
||
|
}
|
||
|
else {
|
||
|
$DEBUG and print " -- $lang isn't a $al\n";
|
||
|
}
|
||
|
}
|
||
|
$q = $accept{'language'}{$selected}{'q'} if $selected;
|
||
|
|
||
|
# If none of the variant's content language tags or
|
||
|
# tag prefixes are listed in the provided
|
||
|
# Accept-Language field, then the value assigned
|
||
|
# is "ql=0.001"
|
||
|
$q = 0.001 unless defined $q;
|
||
|
}
|
||
|
$ql = $q;
|
||
|
}
|
||
|
else {
|
||
|
$ql = 0.5 if $any_lang && exists $accept{'language'};
|
||
|
}
|
||
|
|
||
|
my $q = 1;
|
||
|
my $mbx = undef;
|
||
|
# If no Accept field is given, then the value assigned is "q=1".
|
||
|
# If at least one listed media range matches the variant's media
|
||
|
# type, then the "q" parameter value assigned to the most specific
|
||
|
# of those matched is used (e.g. "text/html;version=3.0" is more
|
||
|
# specific than "text/html", which is more specific than "text/*",
|
||
|
# which in turn is more specific than "*/*"). If not media range
|
||
|
# in the provided Accept field matches the variant's media type,
|
||
|
# then the value assigned is "q=0".
|
||
|
if (exists $accept{'type'} && $ct) {
|
||
|
# First we clean up our content-type
|
||
|
$ct =~ s/\s+//g;
|
||
|
my $params = "";
|
||
|
$params = $1 if $ct =~ s/;(.*)//;
|
||
|
my($type, $subtype) = split("/", $ct, 2);
|
||
|
my %param = ();
|
||
|
for $param (split(/;/, $params)) {
|
||
|
my($pk,$pv) = split(/=/, $param, 2);
|
||
|
$param{$pk} = $pv;
|
||
|
}
|
||
|
|
||
|
my $sel_q = undef;
|
||
|
my $sel_mbx = undef;
|
||
|
my $sel_specificness = 0;
|
||
|
|
||
|
ACCEPT_TYPE:
|
||
|
for $at (keys %{ $accept{'type'} }) {
|
||
|
print "Consider $at...\n" if $DEBUG;
|
||
|
my($at_type, $at_subtype) = split("/", $at, 2);
|
||
|
# Is it a match on the type
|
||
|
next if $at_type ne '*' && $at_type ne $type;
|
||
|
next if $at_subtype ne '*' && $at_subtype ne $subtype;
|
||
|
my $specificness = 0;
|
||
|
$specificness++ if $at_type ne '*';
|
||
|
$specificness++ if $at_subtype ne '*';
|
||
|
# Let's see if content-type parameters also match
|
||
|
while (($pk, $pv) = each %param) {
|
||
|
print "Check if $pk = $pv is true\n" if $DEBUG;
|
||
|
next unless exists $accept{'type'}{$at}{$pk};
|
||
|
next ACCEPT_TYPE
|
||
|
unless $accept{'type'}{$at}{$pk} eq $pv;
|
||
|
print "yes it is!!\n" if $DEBUG;
|
||
|
$specificness++;
|
||
|
}
|
||
|
print "Hurray, type match with specificness = $specificness\n"
|
||
|
if $DEBUG;
|
||
|
|
||
|
if (!defined($sel_q) || $sel_specificness < $specificness) {
|
||
|
$sel_q = $accept{'type'}{$at}{'q'};
|
||
|
$sel_mbx = $accept{'type'}{$at}{'mbx'};
|
||
|
$sel_specificness = $specificness;
|
||
|
}
|
||
|
}
|
||
|
$q = $sel_q || 0;
|
||
|
$mbx = $sel_mbx;
|
||
|
}
|
||
|
|
||
|
my $Q;
|
||
|
if (!defined($mbx) || $mbx >= $bs) {
|
||
|
$Q = $qs * $qe * $qc * $ql * $q;
|
||
|
}
|
||
|
else {
|
||
|
$Q = 0;
|
||
|
print "Variant's size is too large ==> Q=0\n" if $DEBUG;
|
||
|
}
|
||
|
|
||
|
if ($DEBUG) {
|
||
|
$mbx = "undef" unless defined $mbx;
|
||
|
printf "Q=%.4f", $Q;
|
||
|
print " (q=$q, mbx=$mbx, qe=$qe, qc=$qc, ql=$ql, qs=$qs)\n";
|
||
|
}
|
||
|
|
||
|
push(@Q, [$id, $Q, $bs]);
|
||
|
}
|
||
|
|
||
|
|
||
|
@Q = sort { $b->[1] <=> $a->[1] || $a->[2] <=> $b->[2] } @Q;
|
||
|
|
||
|
return @Q if wantarray;
|
||
|
return undef unless @Q;
|
||
|
return undef if $Q[0][1] == 0;
|
||
|
$Q[0][0];
|
||
|
}
|
||
|
|
||
|
1;
|
||
|
|
||
|
__END__
|
||
|
|
||
|
|
||
|
=head1 NAME
|
||
|
|
||
|
HTTP::Negotiate - choose a variant to serve
|
||
|
|
||
|
=head1 SYNOPSIS
|
||
|
|
||
|
use HTTP::Negotiate qw(choose);
|
||
|
|
||
|
# ID QS Content-Type Encoding Char-Set Lang Size
|
||
|
$variants =
|
||
|
[['var1', 1.000, 'text/html', undef, 'iso-8859-1', 'en', 3000],
|
||
|
['var2', 0.950, 'text/plain', 'gzip', 'us-ascii', 'no', 400],
|
||
|
['var3', 0.3, 'image/gif', undef, undef, undef, 43555],
|
||
|
];
|
||
|
|
||
|
@preferred = choose($variants, $request_headers);
|
||
|
$the_one = choose($variants);
|
||
|
|
||
|
=head1 DESCRIPTION
|
||
|
|
||
|
This module provides a complete implementation of the HTTP content
|
||
|
negotiation algorithm specified in F<draft-ietf-http-v11-spec-00.ps>
|
||
|
chapter 12. Content negotiation allows for the selection of a
|
||
|
preferred content representation based upon attributes of the
|
||
|
negotiable variants and the value of the various Accept* header fields
|
||
|
in the request.
|
||
|
|
||
|
The variants are ordered by preference by calling the function
|
||
|
choose().
|
||
|
|
||
|
The first parameter is reference to an array of the variants to
|
||
|
choose among.
|
||
|
Each element in this array is an array with the values [$id, $qs,
|
||
|
$content_type, $content_encoding, $charset, $content_language,
|
||
|
$content_length] whose meanings are described
|
||
|
below. The $content_encoding and $content_language can be either a
|
||
|
single scalar value or an array reference if there are several values.
|
||
|
|
||
|
The second optional parameter is either a HTTP::Headers or a HTTP::Request
|
||
|
object which is searched for "Accept*" headers. If this
|
||
|
parameter is missing, then the accept specification is initialized
|
||
|
from the CGI environment variables HTTP_ACCEPT, HTTP_ACCEPT_CHARSET,
|
||
|
HTTP_ACCEPT_ENCODING and HTTP_ACCEPT_LANGUAGE.
|
||
|
|
||
|
In an array context, choose() returns a list of [variant
|
||
|
identifier, calculated quality, size] tuples. The values are sorted by
|
||
|
quality, highest quality first. If the calculated quality is the same
|
||
|
for two variants, then they are sorted by size (smallest first). I<E.g.>:
|
||
|
|
||
|
(['var1', 1, 2000], ['var2', 0.3, 512], ['var3', 0.3, 1024]);
|
||
|
|
||
|
Note that also zero quality variants are included in the return list
|
||
|
even if these should never be served to the client.
|
||
|
|
||
|
In a scalar context, it returns the identifier of the variant with the
|
||
|
highest score or C<undef> if none have non-zero quality.
|
||
|
|
||
|
If the $HTTP::Negotiate::DEBUG variable is set to TRUE, then a lot of
|
||
|
noise is generated on STDOUT during evaluation of choose().
|
||
|
|
||
|
=head1 VARIANTS
|
||
|
|
||
|
A variant is described by a list of the following values. If the
|
||
|
attribute does not make sense or is unknown for a variant, then use
|
||
|
C<undef> instead.
|
||
|
|
||
|
=over 3
|
||
|
|
||
|
=item identifier
|
||
|
|
||
|
This is a string that you use as the name for the variant. This
|
||
|
identifier for the preferred variants returned by choose().
|
||
|
|
||
|
=item qs
|
||
|
|
||
|
This is a number between 0.000 and 1.000 that describes the "source
|
||
|
quality". This is what F<draft-ietf-http-v11-spec-00.ps> says about this
|
||
|
value:
|
||
|
|
||
|
Source quality is measured by the content provider as representing the
|
||
|
amount of degradation from the original source. For example, a
|
||
|
picture in JPEG form would have a lower qs when translated to the XBM
|
||
|
format, and much lower qs when translated to an ASCII-art
|
||
|
representation. Note, however, that this is a function of the source
|
||
|
- an original piece of ASCII-art may degrade in quality if it is
|
||
|
captured in JPEG form. The qs values should be assigned to each
|
||
|
variant by the content provider; if no qs value has been assigned, the
|
||
|
default is generally "qs=1".
|
||
|
|
||
|
=item content-type
|
||
|
|
||
|
This is the media type of the variant. The media type does not
|
||
|
include a charset attribute, but might contain other parameters.
|
||
|
Examples are:
|
||
|
|
||
|
text/html
|
||
|
text/html;version=2.0
|
||
|
text/plain
|
||
|
image/gif
|
||
|
image/jpg
|
||
|
|
||
|
=item content-encoding
|
||
|
|
||
|
This is one or more content encodings that has been applied to the
|
||
|
variant. The content encoding is generally used as a modifier to the
|
||
|
content media type. The most common content encodings are:
|
||
|
|
||
|
gzip
|
||
|
compress
|
||
|
|
||
|
=item content-charset
|
||
|
|
||
|
This is the character set used when the variant contains text.
|
||
|
The charset value should generally be C<undef> or one of these:
|
||
|
|
||
|
us-ascii
|
||
|
iso-8859-1 ... iso-8859-9
|
||
|
iso-2022-jp
|
||
|
iso-2022-jp-2
|
||
|
iso-2022-kr
|
||
|
unicode-1-1
|
||
|
unicode-1-1-utf-7
|
||
|
unicode-1-1-utf-8
|
||
|
|
||
|
=item content-language
|
||
|
|
||
|
This describes one or more languages that are used in the variant.
|
||
|
Language is described like this in F<draft-ietf-http-v11-spec-00.ps>: A
|
||
|
language is in this context a natural language spoken, written, or
|
||
|
otherwise conveyed by human beings for communication of information to
|
||
|
other human beings. Computer languages are explicitly excluded.
|
||
|
|
||
|
The language tags are defined by RFC 3066. Examples
|
||
|
are:
|
||
|
|
||
|
no Norwegian
|
||
|
en International English
|
||
|
en-US US English
|
||
|
en-cockney
|
||
|
|
||
|
=item content-length
|
||
|
|
||
|
This is the number of bytes used to represent the content.
|
||
|
|
||
|
=back
|
||
|
|
||
|
=head1 ACCEPT HEADERS
|
||
|
|
||
|
The following Accept* headers can be used for describing content
|
||
|
preferences in a request (This description is an edited extract from
|
||
|
F<draft-ietf-http-v11-spec-00.ps>):
|
||
|
|
||
|
=over 3
|
||
|
|
||
|
=item Accept
|
||
|
|
||
|
This header can be used to indicate a list of media ranges which are
|
||
|
acceptable as a response to the request. The "*" character is used to
|
||
|
group media types into ranges, with "*/*" indicating all media types
|
||
|
and "type/*" indicating all subtypes of that type.
|
||
|
|
||
|
The parameter q is used to indicate the quality factor, which
|
||
|
represents the user's preference for that range of media types. The
|
||
|
parameter mbx gives the maximum acceptable size of the response
|
||
|
content. The default values are: q=1 and mbx=infinity. If no Accept
|
||
|
header is present, then the client accepts all media types with q=1.
|
||
|
|
||
|
For example:
|
||
|
|
||
|
Accept: audio/*;q=0.2;mbx=200000, audio/basic
|
||
|
|
||
|
would mean: "I prefer audio/basic (of any size), but send me any audio
|
||
|
type if it is the best available after an 80% mark-down in quality and
|
||
|
its size is less than 200000 bytes"
|
||
|
|
||
|
|
||
|
=item Accept-Charset
|
||
|
|
||
|
Used to indicate what character sets are acceptable for the response.
|
||
|
The "us-ascii" character set is assumed to be acceptable for all user
|
||
|
agents. If no Accept-Charset field is given, the default is that any
|
||
|
charset is acceptable. Example:
|
||
|
|
||
|
Accept-Charset: iso-8859-1, unicode-1-1
|
||
|
|
||
|
|
||
|
=item Accept-Encoding
|
||
|
|
||
|
Restricts the Content-Encoding values which are acceptable in the
|
||
|
response. If no Accept-Encoding field is present, the server may
|
||
|
assume that the client will accept any content encoding. An empty
|
||
|
Accept-Encoding means that no content encoding is acceptable. Example:
|
||
|
|
||
|
Accept-Encoding: compress, gzip
|
||
|
|
||
|
|
||
|
=item Accept-Language
|
||
|
|
||
|
This field is similar to Accept, but restricts the set of natural
|
||
|
languages that are preferred in a response. Each language may be
|
||
|
given an associated quality value which represents an estimate of the
|
||
|
user's comprehension of that language. For example:
|
||
|
|
||
|
Accept-Language: no, en-gb;q=0.8, de;q=0.55
|
||
|
|
||
|
would mean: "I prefer Norwegian, but will accept British English (with
|
||
|
80% comprehension) or German (with 55% comprehension).
|
||
|
|
||
|
=back
|
||
|
|
||
|
|
||
|
=head1 COPYRIGHT
|
||
|
|
||
|
Copyright 1996,2001 Gisle Aas.
|
||
|
|
||
|
This library is free software; you can redistribute it and/or
|
||
|
modify it under the same terms as Perl itself.
|
||
|
|
||
|
=head1 AUTHOR
|
||
|
|
||
|
Gisle Aas <gisle@aas.no>
|
||
|
|
||
|
=cut
|