diff options
Diffstat (limited to 'lib/HTTP/Negotiate.pm')
| -rw-r--r-- | lib/HTTP/Negotiate.pm | 528 |
1 files changed, 528 insertions, 0 deletions
diff --git a/lib/HTTP/Negotiate.pm b/lib/HTTP/Negotiate.pm new file mode 100644 index 0000000..d293ce8 --- /dev/null +++ b/lib/HTTP/Negotiate.pm @@ -0,0 +1,528 @@ +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 |