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
|
package t::Utils;
use strict;
use Exporter ();
use IO::Socket::IP;
use URI ();
use vars qw( @ISA @EXPORT @EXPORT_OK );
@ISA = qw( Exporter );
@EXPORT = qw( &server_start &server_next &fork_proxy &web_ok &bare_request );
@EXPORT_OK = @EXPORT;
use HTTP::Daemon;
use LWP::UserAgent;
# start a simple server
sub server_start {
# create a HTTP::Daemon (on an available port)
my $daemon = HTTP::Daemon->new(
LocalHost => 'localhost',
ReuseAddr => 1,
)
or die "Unable to start web server";
return $daemon;
}
# This must NOT be called in an OO fashion but this way:
# server_next( $server, $coderef, ... );
#
# The optional coderef takes a HTTP::Request as its first argument
# and returns a HTTP::Response. The rest of server_next() arguments
# are passed to &$anwser;
sub server_next {
my $daemon = shift;
my $answer = shift;
# get connection data
my $conn = $daemon->accept;
my $req = $conn->get_request;
# compute some answer
my $rep;
if ( ref $answer eq 'CODE' ) {
$rep = $answer->( $req, @_ );
}
else {
$rep = HTTP::Response->new(
200, 'OK',
HTTP::Headers->new( 'Content-Type' => 'text/plain' ),
sprintf( "You asked for <a href='%s'>%s</a>", ( $req->uri ) x 2 )
);
}
$conn->send_response($rep);
$conn->close;
}
# run a stand-alone proxy
# the proxy accepts an optional coderef to run after serving all requests
sub fork_proxy {
my $proxy = shift;
my $sub = shift;
my $pid = fork;
die "Unable to fork proxy" if not defined $pid;
if ( $pid == 0 ) {
$0 .= " (proxy)";
# this is the http proxy
$proxy->start;
$sub->() if ( defined $sub and ref $sub eq 'CODE' );
exit 0;
}
# back to the parent
return $pid;
}
# check that the web connection is working
sub web_ok {
return 0 if $ENV{NO_NETWORK};
my $ua = LWP::UserAgent->new( env_proxy => 1, timeout => 30 );
my $res =
$ua->request(
HTTP::Request->new( GET => shift||'http://www.google.com/intl/en/' ) );
return $res->is_success;
}
# send a simple request without LWP::UA
# bare_request($url, $headers, $proxy)
sub bare_request {
my ($url, $headers, $proxy) = @_;
# connect directly to the proxy
my $sock = IO::Socket::IP->new(
PeerAddr => URI->new($proxy->url)->host,
PeerPort => URI->new($proxy->url)->port,
Proto => 'tcp'
) or do { warn "Can't connect to the proxy"; return ""; };
# send the request
print $sock "GET $url HTTP/1.0\015\012",
$headers->as_string( "\015\012" ), "\015\012";
my $content = join "", <$sock>;
# close the connection to the proxy
close $sock or warn "close: $!";
return $content;
}
package HTTP::Proxy;
# return the requested internal filter stack
# _filter_stack( body|header, request|response, HTTP::Message )
sub _filter_stack {
my ( $self, $part, $mesg ) = splice( @_, 0, 3 );
die "No <$part><$mesg> filter stack"
unless $part =~ /^(?:header|body)$/
and $mesg =~ /^(?:request|response)$/;
for (@_) {
die "$_ is not a HTTP::Request or HTTP::Response"
unless ( ref $_ ) =~ /^HTTP::(Request|Response)$/;
$self->{ lc $1 } = $_;
}
$self->{response}->request( $self->{request} );
return $self->{$part}{$mesg};
}
|
