root/trunk/lib/Perlbal/HTTPHeaders.pm

Revision 817, 15.2 kB (checked in by mart, 10 months ago)

Add a really basic plugin to issue redirects to canonicalize hostnames.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1######################################################################
2# HTTP header class (both request and response)
3#
4# Copyright 2004, Danga Interactive, Inc.
5# Copyright 2005-2007, Six Apart, Ltd.
6#
7
8package Perlbal::HTTPHeaders;
9use strict;
10use warnings;
11no  warnings qw(deprecated);
12
13use Perlbal;
14
15use fields (
16            'headers',   # href; lowercase header -> comma-sep list of values
17            'origcase',  # href; lowercase header -> provided case
18            'hdorder',   # aref; order headers were received (canonical order)
19            'method',    # scalar; request method (if GET request)
20            'uri',       # scalar; request URI (if GET request)
21            'type',      # 'res' or 'req'
22            'code',      # HTTP response status code
23            'codetext',  # status text that for response code
24            'ver',       # version (string) "1.1"
25            'vernum',    # version (number: major*1000+minor): "1.1" => 1001
26            'responseLine', # first line of HTTP response (if response)
27            'requestLine',  # first line of HTTP request (if request)
28            );
29
30our $HTTPCode = {
31    200 => 'OK',
32    204 => 'No Content',
33    206 => 'Partial Content',
34    301 => 'Permanent Redirect',
35    302 => 'Found',
36    304 => 'Not Modified',
37    400 => 'Bad request',
38    403 => 'Forbidden',
39    404 => 'Not Found',
40    416 => 'Request range not satisfiable',
41    500 => 'Internal Server Error',
42    501 => 'Not Implemented',
43    503 => 'Service Unavailable',
44};
45
46sub fail {
47    return undef unless Perlbal::DEBUG >= 1;
48
49    my $reason = shift;
50    print "HTTP parse failure: $reason\n" if Perlbal::DEBUG >= 1;
51    return undef;
52}
53
54sub http_code_english {
55    my Perlbal::HTTPHeaders $self = shift;
56    if (@_) {
57        return $HTTPCode->{shift()} || "";
58    } else {
59        return "" unless $self->response_code;
60        return $HTTPCode->{$self->response_code} || "";
61    }
62}
63
64sub new_response {
65    my Perlbal::HTTPHeaders $self = shift;
66    $self = fields::new($self) unless ref $self;
67
68    my $code = shift;
69    $self->{headers} = {};
70    $self->{origcase} = {};
71    $self->{hdorder} = [];
72    $self->{method} = undef;
73    $self->{uri} = undef;
74
75    $self->{responseLine} = "HTTP/1.0 $code " . $self->http_code_english($code);
76    $self->{code} = $code;
77    $self->{type} = "httpres";
78
79    Perlbal::objctor($self, $self->{type});
80    return $self;
81}
82*new_response_PERL = \&new_response;
83
84sub new {
85    my Perlbal::HTTPHeaders $self = shift;
86    $self = fields::new($self) unless ref $self;
87
88    my ($hstr_ref, $is_response) = @_;
89    # hstr: headers as a string ref
90    # is_response: bool; is HTTP response (as opposed to request).  defaults to request.
91
92    my $absoluteURIHost = undef;
93
94    my @lines = split(/\r?\n/, $$hstr_ref);
95
96    $self->{headers} = {};
97    $self->{origcase} = {};
98    $self->{hdorder} = [];
99    $self->{method} = undef;
100    $self->{uri} = undef;
101    $self->{type} = ($is_response ? "res" : "req");
102    Perlbal::objctor($self, $self->{type});
103
104    # check request line
105    if ($is_response) {
106        $self->{responseLine} = (shift @lines) || "";
107
108        # check for valid response line
109        return fail("Bogus response line") unless
110            $self->{responseLine} =~ m!^HTTP\/(\d+)\.(\d+)\s+(\d+)\s+(.*)$!;
111
112        my ($ver_ma, $ver_mi, $code) = ($1, $2, $3);
113        $self->code($code, $4);
114
115        # version work so we know what version the backend spoke
116        unless (defined $ver_ma) {
117            ($ver_ma, $ver_mi) = (0, 9);
118        }
119        $self->{ver} = "$ver_ma.$ver_mi";
120        $self->{vernum} = $ver_ma*1000 + $ver_mi;
121    } else {
122        $self->{requestLine} = (shift @lines) || "";
123
124        # check for valid request line
125        return fail("Bogus request line") unless
126            $self->{requestLine} =~ m!^(\w+) ((?:\*|(?:\S*?)))(?: HTTP/(\d+)\.(\d+))$!;
127
128        $self->{method} = $1;
129        $self->{uri} = $2;
130
131        my ($ver_ma, $ver_mi) = ($3, $4);
132
133        # now check uri for not being a uri
134        if ($self->{uri} =~ m!^http://([^/:]+?)(?::\d+)?(/.*)?$!) {
135            $absoluteURIHost = lc($1);
136            $self->{uri} = $2 || "/"; # "http://www.foo.com" yields no path, so default to "/"
137        }
138
139        # default to HTTP/0.9
140        unless (defined $ver_ma) {
141            ($ver_ma, $ver_mi) = (0, 9);
142        }
143
144        $self->{ver} = "$ver_ma.$ver_mi";
145        $self->{vernum} = $ver_ma*1000 + $ver_mi;
146    }
147
148    my $last_header = undef;
149    foreach my $line (@lines) {
150        if ($line =~ /^\s/) {
151            next unless defined $last_header;
152            $self->{headers}{$last_header} .= $line;
153        } elsif ($line =~ /^([^\x00-\x20\x7f()<>@,;:\\\"\/\[\]?={}]+):\s*(.*)$/) {
154            # RFC 2616:
155            # sec 4.2:
156            #     message-header = field-name ":" [ field-value ]
157            #     field-name     = token
158            # sec 2.2:
159            #     token          = 1*<any CHAR except CTLs or separators>
160
161            $last_header = lc($1);
162            if (defined $self->{headers}{$last_header}) {
163                if ($last_header eq "set-cookie") {
164                    # cookie spec doesn't allow merged headers for set-cookie,
165                    # so instead we do this hack so to_string below does the right
166                    # thing without needing to be arrayref-aware or such.  also
167                    # this lets client code still modify/delete this data
168                    # (but retrieving the value of "set-cookie" will be broken)
169                    $self->{headers}{$last_header} .= "\r\nSet-Cookie: $2";
170                } else {
171                    # normal merged header case (according to spec)
172                    $self->{headers}{$last_header} .= ", $2";
173                }
174            } else {
175                $self->{headers}{$last_header} = $2;
176                $self->{origcase}{$last_header} = $1;
177                push @{$self->{hdorder}}, $last_header;
178            }
179        } else {
180            return fail("unknown header line");
181        }
182    }
183
184    # override the host header if an absolute URI was provided
185    $self->header('Host', $absoluteURIHost)
186        if defined $absoluteURIHost;
187
188    # now error if no host
189    return fail("HTTP 1.1 requires host header")
190        if !$is_response && $self->{vernum} >= 1001 && !$self->header('Host');
191
192    return $self;
193}
194*new_PERL = \&new;
195
196sub _codetext {
197    my Perlbal::HTTPHeaders $self = shift;
198    return $self->{codetext} if $self->{codetext};
199    return $self->http_code_english;
200}
201
202sub code {
203    my Perlbal::HTTPHeaders $self = shift;
204    my ($code, $text) = @_;
205    $self->{codetext} = $text;
206    if (! defined $self->{code} || $code != $self->{code}) {
207        $self->{code} = $code+0;
208        if ($self->{responseLine}) {
209            $self->{responseLine} = "HTTP/1.0 $code " . $self->http_code_english;
210        }
211    }
212}
213
214sub response_code {
215    my Perlbal::HTTPHeaders $self = $_[0];
216    return $self->{code};
217}
218
219sub request_method {
220    my Perlbal::HTTPHeaders $self = shift;
221    return $self->{method};
222}
223
224sub request_uri {
225    my Perlbal::HTTPHeaders $self = shift;
226    return $self->{uri};
227}
228
229sub set_request_uri {
230    my Perlbal::HTTPHeaders $self = shift;
231    return unless $self->{requestLine};
232
233    my $uri = shift;
234
235    return unless defined $uri and length $uri;
236
237    my $ver = $self->{ver};
238
239    if ($ver == 0.9) {
240        $self->{requestLine} = sprintf("%s %s", $self->{method}, $uri);
241    } else {
242        $self->{requestLine} = sprintf("%s %s HTTP/%s", $self->{method}, $uri, $ver);
243    }
244
245    return $self->{uri} = $uri;
246}
247
248sub version_number {
249    my Perlbal::HTTPHeaders $self = $_[0];
250    return $self->{vernum} unless $_[1];
251    return $self->{vernum} = $_[1];
252}
253
254sub header {
255    my Perlbal::HTTPHeaders $self = shift;
256    my $key = shift;
257    return $self->{headers}{lc($key)} unless @_;
258
259    # adding a new header
260    my $origcase = $key;
261    $key = lc($key);
262    unless (exists $self->{headers}{$key}) {
263        push @{$self->{hdorder}}, $key;
264        $self->{origcase}{$key} = $origcase;
265    }
266
267    return $self->{headers}{$key} = shift;
268}
269
270sub headers_list {
271    my Perlbal::HTTPHeaders $self = shift;
272    return [$self->{headers} ? keys %{ $self->{headers} } : ()];
273}
274
275sub to_string_ref {
276    my Perlbal::HTTPHeaders $self = shift;
277    my $st = join("\r\n",
278                  $self->{requestLine} || $self->{responseLine},
279                  (map { "$self->{origcase}{$_}: $self->{headers}{$_}" }
280                   grep { defined $self->{headers}{$_} }
281                   @{$self->{hdorder}}),
282                  '', '');  # final \r\n\r\n
283    return \$st;
284}
285
286sub clone {
287    my Perlbal::HTTPHeaders $self = shift;
288    my $new = fields::new($self);
289    foreach (qw(method uri type code codetext ver vernum responseLine requestLine)) {
290        $new->{$_} = $self->{$_};
291    }
292
293    # mark this object as constructed
294    Perlbal::objctor($new, $new->{type});
295
296    $new->{headers} = { %{$self->{headers}} };
297    $new->{origcase} = { %{$self->{origcase}} };
298    $new->{hdorder} = [ @{$self->{hdorder}} ];
299    return $new;
300}
301
302sub set_version {
303    my Perlbal::HTTPHeaders $self = shift;
304    my $ver = shift;
305
306    die "Bogus version" unless $ver =~ /^(\d+)\.(\d+)$/;
307    my ($ver_ma, $ver_mi) = ($1, $2);
308
309    # check for req, as the other can be res or httpres
310    if ($self->{type} eq 'req') {
311        $self->{requestLine} = "$self->{method} $self->{uri} HTTP/$ver";
312    } else {
313        $self->{responseLine} = "HTTP/$ver $self->{code} " . $self->_codetext;
314    }
315    $self->{ver} = "$ver_ma.$ver_mi";
316    $self->{vernum} = $ver_ma*1000 + $ver_mi;
317    return $self;
318}
319
320# using all available information, attempt to determine the content length of
321# the message body being sent to us.
322sub content_length {
323    my Perlbal::HTTPHeaders $self = shift;
324
325    # shortcuts depending on our method/code, depending on what we are
326    if ($self->{type} eq 'req') {
327        # no content length for head requests
328        return 0 if $self->{method} eq 'HEAD';
329    } elsif ($self->{type} eq 'res' || $self->{type} eq 'httpres') {
330        # no content length in any of these
331        if ($self->{code} == 304 || $self->{code} == 204 ||
332            ($self->{code} >= 100 && $self->{code} <= 199)) {
333            return 0;
334        }
335    }
336
337    # the normal case for a GET/POST, etc.  real data coming back
338    # also, an OPTIONS requests generally has a defined but 0 content-length
339    if (defined(my $clen = $self->header("Content-Length"))) {
340        return $clen;
341    }
342
343    # if we get here, nothing matched, so we don't definitively know what the
344    # content length is.  this is usually an error, but we try to work around it.
345    return undef;
346}
347
348# answers the question: "should a response to this person specify keep-alive,
349# given the request (self) and the backend response?"  this is used in proxy
350# mode to determine based on the client's request and the backend's response
351# whether or not the response from the proxy (us) should do keep-alive.
352#
353# FIXME: this is called too often (especially with service selector),
354# and should be redesigned to be simpler, and/or cached on the
355# connection.  there's too much duplication with res_keep_alive.
356sub req_keep_alive {
357    my Perlbal::HTTPHeaders $self = $_[0];
358    my Perlbal::HTTPHeaders $res = $_[1] or Carp::confess("ASSERT: No response headers given");
359
360    # get the connection header now (saves warnings later)
361    my $conn = lc ($self->header('Connection') || '');
362
363    # check the client
364    if ($self->version_number < 1001) {
365        # they must specify a keep-alive header
366        return 0 unless $conn =~ /\bkeep-alive\b/i;
367    }
368
369    # so it must be 1.1 which means keep-alive is on, unless they say not to
370    return 0 if $conn =~ /\bclose\b/i;
371
372    # if we get here, the user wants keep-alive and seems to support it,
373    # so we make sure that the response is in a form that we can understand
374    # well enough to do keep-alive.  FIXME: support chunked encoding in the
375    # future, which means this check changes.
376    return 1 if defined $res->header('Content-length') ||
377        $res->response_code == 304 || # not modified
378        $res->response_code == 204 || # no content
379        $self->request_method eq 'HEAD';
380
381    # fail-safe, no keep-alive
382    return 0;
383}
384
385# if an options response from a backend looks like it can do keep-alive.
386sub res_keep_alive_options {
387    my Perlbal::HTTPHeaders $self = $_[0];
388    return $self->res_keep_alive(undef, 1);
389}
390
391# answers the question: "is the backend expected to stay open?"  this
392# is a combination of the request we sent to it and the response they
393# sent...
394
395# FIXME: this is called too often (especially with service selector),
396# and should be redesigned to be simpler, and/or cached on the
397# connection.  there's too much duplication with req_keep_alive.
398sub res_keep_alive {
399    my Perlbal::HTTPHeaders $self = $_[0];
400    my Perlbal::HTTPHeaders $req = $_[1];
401    my $is_options = $_[2];
402    Carp::confess("ASSERT: No request headers given") unless $req || $is_options;
403
404    # get the connection header now (saves warnings later)
405    my $conn = lc ($self->header('Connection') || '');
406
407    # if they said Connection: close, it's always not keep-alive
408    return 0 if $conn =~ /\bclose\b/i;
409
410    # handle the http 1.0/0.9 case which requires keep-alive specified
411    if ($self->version_number < 1001) {
412        # must specify keep-alive, and must have a content length OR
413        # the request must be a head request
414        return 1 if
415            $conn =~ /\bkeep-alive\b/i &&
416            ($is_options ||
417             defined $self->header('Content-length') ||
418             $req->request_method eq 'HEAD' ||
419             $self->response_code == 304 || # not modified
420             $self->response_code == 204
421             ); # no content
422
423        return 0;
424    }
425
426    # HTTP/1.1 case.  defaults to keep-alive, per spec, unless
427    # asked for otherwise (checked above)
428    # FIXME: make sure we handle a HTTP/1.1 response from backend
429    # with connection: close, no content-length, going to a
430    # HTTP/1.1 persistent client.  we'll have to add chunk markers.
431    # (not here, obviously)
432    return 1;
433}
434
435# returns (status, range_start, range_end) when given a size
436# status = 200 - invalid or non-existent range header.  serve normally.
437# status = 206 - parseable range is good.  serve partial content.
438# status = 416 - Range is unsatisfiable
439sub range {
440    my Perlbal::HTTPHeaders $self = $_[0];
441    my $size = $_[1];
442
443    my $not_satisfiable;
444    my $range = $self->header("Range");
445
446    return 200 unless
447        $range &&
448        defined $size &&
449        $range =~ /^bytes=(\d*)-(\d*)$/;
450
451    my ($range_start, $range_end) = ($1, $2);
452
453    undef $range_start if $range_start eq '';
454    undef $range_end if $range_end eq '';
455    return 200 unless defined($range_start) or defined($range_end);
456
457    if (defined($range_start) and defined($range_end) and $range_start > $range_end)  {
458        return 416;
459    } elsif (not defined($range_start) and defined($range_end) and $range_end == 0)  {
460        return 416;
461    } elsif (defined($range_start) and $size <= $range_start) {
462        return 416;
463    }
464
465    $range_start = 0        unless defined($range_start);
466    $range_end  = $size - 1 unless defined($range_end) and $range_end < $size;
467
468    return (206, $range_start, $range_end);
469}
470
471
472sub DESTROY {
473    my Perlbal::HTTPHeaders $self = shift;
474    Perlbal::objdtor($self, $self->{type});
475}
476
4771;
478
479# Local Variables:
480# mode: perl
481# c-basic-indent: 4
482# indent-tabs-mode: nil
483# End:
Note: See TracBrowser for help on using the browser.