1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
|
package HTTP::Proxy::HeaderFilter::standard;
use strict;
use HTTP::Proxy;
use HTTP::Headers::Util qw( split_header_words );
use HTTP::Proxy::HeaderFilter;
use vars qw( @ISA );
@ISA = qw( HTTP::Proxy::HeaderFilter );
# known hop-by-hop headers
my @hopbyhop =
qw( Connection Keep-Alive Proxy-Authenticate Proxy-Authorization
TE Trailers Transfer-Encoding Upgrade Proxy-Connection Public );
# standard proxy header filter (RFC 2616)
sub filter {
my ( $self, $headers, $message ) = @_;
# the Via: header
my $via = $message->protocol() || '';
if ( $self->proxy->via and $via =~ s!HTTP/!! ) {
$via .= " " . $self->proxy->via;
$headers->header(
Via => join ', ',
$message->headers->header('Via') || (), $via
);
}
# the X-Forwarded-For header
$headers->push_header(
X_Forwarded_For => $self->proxy->client_socket->peerhost )
if $message->isa( 'HTTP::Request' ) && $self->proxy->x_forwarded_for;
# make a list of hop-by-hop headers
my %h2h = map { (lc) => 1 } @hopbyhop;
my $hop = HTTP::Headers->new();
my $client = HTTP::Headers->new();
$h2h{ lc $_->[0] } = 1
for map { split_header_words($_) } $headers->header('Connection');
# hop-by-hop headers are set aside
# as well as LWP::UserAgent Client-* headers
$headers->scan(
sub {
my ( $k, $v ) = @_;
if ( $h2h{lc $k} ) {
$hop->push_header( $k => $v );
$headers->remove_header($k);
}
if( $k =~ /^Client-/ ) {
$client->push_header( $k => $v );
$headers->remove_header($k);
}
}
);
# set the hop-by-hop and client headers in the proxy
# only the end-to-end headers are left in the message
$self->proxy->hop_headers($hop);
$self->proxy->client_headers($client);
# handle Max-Forwards
if ( $message->isa('HTTP::Request')
and defined $headers->header('Max-Forwards') ) {
my ( $max, $method ) =
( $headers->header('Max-Forwards'), $message->method );
if ( $max == 0 ) {
# answer directly TRACE ou OPTIONS
if ( $method eq 'TRACE' ) {
my $response =
HTTP::Response->new( 200, 'OK',
HTTP::Headers->new( Content_Type => 'message/http'
, Content_Length => 0),
$message->as_string );
$self->proxy->response($response);
}
elsif ( $method eq 'OPTIONS' ) {
my $response = HTTP::Response->new(200);
$response->header( Allow => join ', ', @HTTP::Proxy::METHODS );
$self->proxy->response($response);
}
}
# The Max-Forwards header field MAY be ignored for all
# other methods defined by this specification (RFC 2616)
elsif ( $method =~ /^(?:TRACE|OPTIONS)/ ) {
$headers->header( 'Max-Forwards' => --$max );
}
}
# no encoding accepted (gzip, compress, deflate)
# if we plan to do anything with the response body
$headers->remove_header( 'Accept-Encoding' )
if @{ $self->proxy->{body}{response}{filters} };
}
1;
__END__
=head1 NAME
HTTP::Proxy::HeaderFilter::standard - An internal filter to respect RFC2616
=head1 DESCRIPTION
This is an internal filter used by HTTP::Proxy to enforce behaviour
compliant with RFC 2616.
=head1 METHOD
This filter implements a single method that is called automatically:
=over 4
=item filter()
Enforce RFC 2616-compliant behaviour, by adding the C<Via:> and
C<X-Forwarded-For:> headers (except when the proxy was instructed not
to add them), decrementing the C<Max-Forwards:> header and removing
the hop-by-hop and L<LWP::UserAgent> headers.
Note that the filter will automatically remove the C<Accept-Encoding>
headers if the proxy has at least one L<HTTP::Proxy::BodyFilter> filter.
(This is to ensure that the filters will receive uncompressed data.)
=back
=head1 SEE ALSO
L<HTTP::Proxy>, L<HTTP::Proxy::HeaderFilter>, RFC 2616.
=head1 AUTHOR
Philippe "BooK" Bruhat, E<lt>book@cpan.orgE<gt>.
Thanks to Gisle Aas, for directions regarding the handling of the
hop-by-hop headers.
=head1 COPYRIGHT
Copyright 2003-2013, Philippe Bruhat.
=head1 LICENSE
This module is free software; you can redistribute it or modify it under
the same terms as Perl itself.
=cut
|
