line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
|
2
|
1
|
|
|
1
|
|
697
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
32
|
|
3
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
67
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package App::HTTP_Proxy_IMP; |
6
|
|
|
|
|
|
|
our $VERSION = '0.956'; |
7
|
|
|
|
|
|
|
use fields ( |
8
|
1
|
|
|
|
|
7
|
'addr', # \@addr to listen on |
9
|
|
|
|
|
|
|
'impns', # \@namespace for IMP plugins |
10
|
|
|
|
|
|
|
'filter', # \@plugins to load |
11
|
|
|
|
|
|
|
'logrx', # regexp for filtering log messages |
12
|
|
|
|
|
|
|
'pcapdir', # dir to store pcap files of requests |
13
|
|
|
|
|
|
|
'mitm_ca', # file containing cert and key of proxy cert |
14
|
|
|
|
|
|
|
'capath', # path to CA to verify server cert |
15
|
|
|
|
|
|
|
'no_check_certificate', # don't check server certificates |
16
|
|
|
|
|
|
|
'childs', # use this number of childs ( 0 = don't fork) |
17
|
|
|
|
|
|
|
'max_connect_per_child', # max number of connections before child exits |
18
|
1
|
|
|
1
|
|
908
|
); |
|
1
|
|
|
|
|
1706
|
|
19
|
|
|
|
|
|
|
|
20
|
1
|
|
|
1
|
|
831
|
use App::HTTP_Proxy_IMP::IMP; |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
use App::HTTP_Proxy_IMP::Conn; |
22
|
|
|
|
|
|
|
use App::HTTP_Proxy_IMP::Request; |
23
|
|
|
|
|
|
|
use App::HTTP_Proxy_IMP::Relay; |
24
|
|
|
|
|
|
|
use AnyEvent; |
25
|
|
|
|
|
|
|
use Getopt::Long qw(:config posix_default bundling); |
26
|
|
|
|
|
|
|
use App::HTTP_Proxy_IMP::Debug qw(debug $DEBUG $DEBUG_RX); |
27
|
|
|
|
|
|
|
use Net::Inspect::Debug qw(%TRACE); |
28
|
|
|
|
|
|
|
use IO::Socket::SSL::Intercept; |
29
|
|
|
|
|
|
|
use IO::Socket::SSL::Utils; |
30
|
|
|
|
|
|
|
use Carp 'croak'; |
31
|
|
|
|
|
|
|
use POSIX '_exit'; |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
# try IPv6 using IO::Socket::IP or IO::Socket::INET6 |
35
|
|
|
|
|
|
|
# fallback to IPv4 only |
36
|
|
|
|
|
|
|
my $sockclass; |
37
|
|
|
|
|
|
|
BEGIN { |
38
|
|
|
|
|
|
|
for(qw( IO::Socket::IP IO::Socket::INET6 IO::Socket::INET )) { |
39
|
|
|
|
|
|
|
if ( eval "require $_" ) { |
40
|
|
|
|
|
|
|
$sockclass = $_; |
41
|
|
|
|
|
|
|
last; |
42
|
|
|
|
|
|
|
} |
43
|
|
|
|
|
|
|
} |
44
|
|
|
|
|
|
|
$sockclass or die "cannot find usable socket class"; |
45
|
|
|
|
|
|
|
} |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
sub new { |
49
|
|
|
|
|
|
|
my ($class,@args) = @_; |
50
|
|
|
|
|
|
|
my $self = fields::new($class); |
51
|
|
|
|
|
|
|
$self->{impns} = [qw(App::HTTP_Proxy_IMP::IMP Net::IMP::HTTP Net::IMP)]; |
52
|
|
|
|
|
|
|
%$self = ( %$self, %{ shift(@args) }) if @args && ref($args[0]); |
53
|
|
|
|
|
|
|
$self->getoptions(@args) if @args; |
54
|
|
|
|
|
|
|
return $self; |
55
|
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
sub start { |
58
|
|
|
|
|
|
|
my $self = shift; |
59
|
|
|
|
|
|
|
$self = $self->new(@_) or return if ! ref($self); # package->start |
60
|
|
|
|
|
|
|
|
61
|
|
|
|
|
|
|
my $pcapdir = $self->{pcapdir}; |
62
|
|
|
|
|
|
|
if ( $pcapdir ) { |
63
|
|
|
|
|
|
|
croak("pcap directory not writeable") unless -d $pcapdir && -w _; |
64
|
|
|
|
|
|
|
eval { require Net::PcapWriter } or croak( |
65
|
|
|
|
|
|
|
"cannot load Net::PcapWriter, which is needed with --pcapdir option"); |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
my $mitm; |
69
|
|
|
|
|
|
|
if ( my $f = $self->{mitm_ca} ) { |
70
|
|
|
|
|
|
|
my $serial = 1; |
71
|
|
|
|
|
|
|
my $cache = {}; |
72
|
|
|
|
|
|
|
my $cachedir = "$f.cache"; |
73
|
|
|
|
|
|
|
if ( -d $cachedir || mkdir($cachedir,0700)) { |
74
|
|
|
|
|
|
|
for my $f (glob("$cachedir/*.pem")) { |
75
|
|
|
|
|
|
|
-f $f && -r _ && -s _ or next; |
76
|
|
|
|
|
|
|
my $time = (stat(_))[9]; |
77
|
|
|
|
|
|
|
my $key = PEM_file2key($f) or next; |
78
|
|
|
|
|
|
|
my $cert = PEM_file2cert($f) or next; |
79
|
|
|
|
|
|
|
my $sn = CERT_asHash($cert)->{serial}; |
80
|
|
|
|
|
|
|
$serial = $sn+1 if $sn>=$serial; |
81
|
|
|
|
|
|
|
my ($id) = $f=~m{/([^/]+)\.pem$}; |
82
|
|
|
|
|
|
|
$cache->{$id} = { |
83
|
|
|
|
|
|
|
cert => $cert, |
84
|
|
|
|
|
|
|
key => $key, |
85
|
|
|
|
|
|
|
atime => $time, |
86
|
|
|
|
|
|
|
}; |
87
|
|
|
|
|
|
|
debug("loaded certificate id=$id from cache"); |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
my $cache_hash = $cache; |
91
|
|
|
|
|
|
|
$cache = sub { |
92
|
|
|
|
|
|
|
my $id = shift; |
93
|
|
|
|
|
|
|
my $e; |
94
|
|
|
|
|
|
|
if ( ! @_ ){ # get |
95
|
|
|
|
|
|
|
$e = $cache_hash->{$id} or return; |
96
|
|
|
|
|
|
|
} else { |
97
|
|
|
|
|
|
|
my ($cert,$key) = @_; |
98
|
|
|
|
|
|
|
$e = $cache_hash->{$id} = { |
99
|
|
|
|
|
|
|
cert => $cert, |
100
|
|
|
|
|
|
|
key => $key, |
101
|
|
|
|
|
|
|
}; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
my $f = "$cachedir/$id.pem"; |
104
|
|
|
|
|
|
|
if ( @_ || ! -f $f and open( my $fh,">",$f )) { |
105
|
|
|
|
|
|
|
debug("save mitm certificate and key to $cachedir/$id.pem"); |
106
|
|
|
|
|
|
|
print $fh PEM_cert2string($e->{cert}), |
107
|
|
|
|
|
|
|
PEM_key2string($e->{key}) |
108
|
|
|
|
|
|
|
} else { |
109
|
|
|
|
|
|
|
utime(undef,undef,$f); |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
$e->{atime} = time(); |
112
|
|
|
|
|
|
|
return ($e->{cert},$e->{key}); |
113
|
|
|
|
|
|
|
}; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
$mitm = IO::Socket::SSL::Intercept->new( |
117
|
|
|
|
|
|
|
proxy_cert_file => $f, |
118
|
|
|
|
|
|
|
proxy_key_file => $f, |
119
|
|
|
|
|
|
|
cache => $cache, |
120
|
|
|
|
|
|
|
serial => $serial, |
121
|
|
|
|
|
|
|
); |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
my $imp_factory; |
125
|
|
|
|
|
|
|
my $filter = $self->{filter}; |
126
|
|
|
|
|
|
|
if ($filter && @$filter ) { |
127
|
|
|
|
|
|
|
my $ns = $self->{impns}; |
128
|
|
|
|
|
|
|
my @mod; |
129
|
|
|
|
|
|
|
my $ev = App::HTTP_Proxy_IMP::EventLoop->new; |
130
|
|
|
|
|
|
|
for my $f (@$filter) { |
131
|
|
|
|
|
|
|
if ( ref($f) ) { |
132
|
|
|
|
|
|
|
# already factory object |
133
|
|
|
|
|
|
|
push @mod,$f; |
134
|
|
|
|
|
|
|
next; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
my $f = $f; # copy |
138
|
|
|
|
|
|
|
my $args = $f =~s{=(.*)}{} && $1; |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
my $found; |
141
|
|
|
|
|
|
|
for my $prefix ('', map { "${_}::" } @$ns) { |
142
|
|
|
|
|
|
|
my $mod = $prefix.$f; |
143
|
|
|
|
|
|
|
if ( eval "require $mod" ) { |
144
|
|
|
|
|
|
|
$found = $mod; |
145
|
|
|
|
|
|
|
last; |
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
croak("IMP module $f could not be loaded: $@") if ! $found; |
149
|
|
|
|
|
|
|
my %args = $args ? $found->str2cfg($args) :(); |
150
|
|
|
|
|
|
|
my @err = $found->validate_cfg(%args); |
151
|
|
|
|
|
|
|
die "bad config for $found: @err" if @err; |
152
|
|
|
|
|
|
|
push @mod, $found->new_factory(%args, eventlib => $ev ) |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
my $logsub = $self->{logrx} && do { |
156
|
|
|
|
|
|
|
my $rx = $self->{logrx}; |
157
|
|
|
|
|
|
|
sub { |
158
|
|
|
|
|
|
|
my ($level,$msg,$dir,$off,$len) = @_; |
159
|
|
|
|
|
|
|
$level =~ $rx or return; |
160
|
|
|
|
|
|
|
print STDERR "[$level]($dir:$off,$len) $msg\n"; |
161
|
|
|
|
|
|
|
}; |
162
|
|
|
|
|
|
|
}; |
163
|
|
|
|
|
|
|
$imp_factory = App::HTTP_Proxy_IMP::IMP->new_factory( |
164
|
|
|
|
|
|
|
mod => \@mod, |
165
|
|
|
|
|
|
|
logsub => $logsub, |
166
|
|
|
|
|
|
|
); |
167
|
|
|
|
|
|
|
} |
168
|
|
|
|
|
|
|
|
169
|
|
|
|
|
|
|
if ( $self->{childs} ) { |
170
|
|
|
|
|
|
|
$self->{childs} = [ map { undef } (1..$self->{childs}) ]; |
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
my $capath; |
174
|
|
|
|
|
|
|
if ( ! $mitm ) { |
175
|
|
|
|
|
|
|
# no interception = no certificate checking |
176
|
|
|
|
|
|
|
} elsif ( $self->{no_check_certificate} ) { |
177
|
|
|
|
|
|
|
# no certificate checking |
178
|
|
|
|
|
|
|
} elsif ( $capath = $self->{capath} ) { |
179
|
|
|
|
|
|
|
# use this capath |
180
|
|
|
|
|
|
|
} else { |
181
|
|
|
|
|
|
|
# try to guess capath |
182
|
|
|
|
|
|
|
if ( eval { require Mozilla::CA } ) { |
183
|
|
|
|
|
|
|
$capath = Mozilla::CA::SSL_ca_file(); |
184
|
|
|
|
|
|
|
} elsif ( glob("/etc/ssl/certs/*.pem") ) { |
185
|
|
|
|
|
|
|
$capath = "/etc/ssl/certs"; |
186
|
|
|
|
|
|
|
} elsif ( -f "/etc/ssl/certs.pem" && -r _ && -s _ ) { |
187
|
|
|
|
|
|
|
$capath = "/etc/ssl/certs.pem"; |
188
|
|
|
|
|
|
|
} else { |
189
|
|
|
|
|
|
|
croak "cannot determine CA path, needed for SSL interception" |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
# create connection fabric, attach request handling |
194
|
|
|
|
|
|
|
my $req = App::HTTP_Proxy_IMP::Request->new; |
195
|
|
|
|
|
|
|
my $conn = App::HTTP_Proxy_IMP::Conn->new($req, |
196
|
|
|
|
|
|
|
pcapdir => $pcapdir, |
197
|
|
|
|
|
|
|
mitm => $mitm, |
198
|
|
|
|
|
|
|
capath => $capath, |
199
|
|
|
|
|
|
|
imp_factory => $imp_factory |
200
|
|
|
|
|
|
|
); |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
# create listeners |
203
|
|
|
|
|
|
|
my @listen; |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
$self->{addr} = [ $self->{addr} ] |
206
|
|
|
|
|
|
|
if $self->{addr} && ref($self->{addr}) ne 'ARRAY'; |
207
|
|
|
|
|
|
|
for my $spec (@{$self->{addr}}) { |
208
|
|
|
|
|
|
|
my ($addr,$upstream) = |
209
|
|
|
|
|
|
|
ref($spec) eq 'ARRAY' ? @$spec: |
210
|
|
|
|
|
|
|
ref($spec) ? ( $spec,undef ): |
211
|
|
|
|
|
|
|
split('=',$spec,2); |
212
|
|
|
|
|
|
|
my $srv; |
213
|
|
|
|
|
|
|
if ( ref($addr)) { |
214
|
|
|
|
|
|
|
# listing socket already |
215
|
|
|
|
|
|
|
$srv = $addr; |
216
|
|
|
|
|
|
|
(my $port,$addr) = AnyEvent::Socket::unpack_sockaddr( getsockname($srv)); |
217
|
|
|
|
|
|
|
$addr = AnyEvent::Socket::format_address($addr); |
218
|
|
|
|
|
|
|
$addr = $addr =~m{:} ? "[$addr]:$port" : "$addr:$port"; |
219
|
|
|
|
|
|
|
} else { |
220
|
|
|
|
|
|
|
$srv = $sockclass->new( |
221
|
|
|
|
|
|
|
LocalAddr => $addr, |
222
|
|
|
|
|
|
|
Listen => 10, |
223
|
|
|
|
|
|
|
ReuseAddr => 1, |
224
|
|
|
|
|
|
|
) or croak("cannot listen to $addr: $!"); |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
$spec = [ $addr,$upstream,$srv ]; |
227
|
|
|
|
|
|
|
push @listen, AnyEvent->io( |
228
|
|
|
|
|
|
|
fh => $srv, |
229
|
|
|
|
|
|
|
poll => 'r', |
230
|
|
|
|
|
|
|
cb => sub { |
231
|
|
|
|
|
|
|
my $cl = $srv->accept or return; |
232
|
|
|
|
|
|
|
debug("new request from %s:%s on %s",$cl->peerhost,$cl->peerport,$addr); |
233
|
|
|
|
|
|
|
if ( $self->{max_connect_per_child}>0 |
234
|
|
|
|
|
|
|
and 0 == --$self->{max_connect_per_child} ) { |
235
|
|
|
|
|
|
|
# last connection for child |
236
|
|
|
|
|
|
|
# fork-away and handle outstanding connections, parent will |
237
|
|
|
|
|
|
|
# in the meantime fork a replacement child |
238
|
|
|
|
|
|
|
defined( my $pid = fork()) or die "failed to fork: $!"; |
239
|
|
|
|
|
|
|
if ( $pid ) { |
240
|
|
|
|
|
|
|
$DEBUG && debug("forked away child $$ as $pid"); |
241
|
|
|
|
|
|
|
_exit(0); |
242
|
|
|
|
|
|
|
} else { |
243
|
|
|
|
|
|
|
$0 =~s{\Q[worker]}{[death-trip]}; |
244
|
|
|
|
|
|
|
undef @listen; # only handle outstanding connections |
245
|
|
|
|
|
|
|
App::HTTP_Proxy_IMP::Relay->exit_if_no_relays(1); |
246
|
|
|
|
|
|
|
$DEBUG && debug( |
247
|
|
|
|
|
|
|
"forked away child $$ to handle last connections"); |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
|
App::HTTP_Proxy_IMP::Relay->new($cl,$upstream,$conn); |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
); |
253
|
|
|
|
|
|
|
debug("listening on $addr"); |
254
|
|
|
|
|
|
|
} |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
$self->{max_connect_per_child} = 0 if ! $self->{childs}; |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
return 1 if defined wantarray; |
259
|
|
|
|
|
|
|
$self->loop; |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
sub DESTROY { |
263
|
|
|
|
|
|
|
my $self = shift; |
264
|
|
|
|
|
|
|
ref(my $ch = delete $self->{childs}) or return; |
265
|
|
|
|
|
|
|
kill 9, grep { $_ } @$ch; |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
{ |
269
|
|
|
|
|
|
|
my $loop; |
270
|
|
|
|
|
|
|
my @once; |
271
|
|
|
|
|
|
|
sub once { |
272
|
|
|
|
|
|
|
shift; |
273
|
|
|
|
|
|
|
push @once, shift; |
274
|
|
|
|
|
|
|
$loop->send if $loop; |
275
|
|
|
|
|
|
|
} |
276
|
|
|
|
|
|
|
sub loop { |
277
|
|
|
|
|
|
|
my $self = shift; |
278
|
|
|
|
|
|
|
return $self->parent_loop if $self->{childs}; |
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
my $usr2 = AnyEvent->signal( signal => 'USR2', cb => sub { |
281
|
|
|
|
|
|
|
my $was_debug = $DEBUG; |
282
|
|
|
|
|
|
|
$DEBUG = 1; |
283
|
|
|
|
|
|
|
debug("($$) ".( $was_debug ? 'disable':'enable' ) ." debugging"); |
284
|
|
|
|
|
|
|
$DEBUG = ! $was_debug; |
285
|
|
|
|
|
|
|
}); |
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
# on SIGUSR1 dump state of all relays |
288
|
|
|
|
|
|
|
my $usr1 = AnyEvent->signal( signal => 'USR1', cb => sub { |
289
|
|
|
|
|
|
|
# temporaly enable debugging, even if off |
290
|
|
|
|
|
|
|
my $msg = "-------- active relays ------------------\n"; |
291
|
|
|
|
|
|
|
my @relays = App::HTTP_Proxy_IMP::Relay->relays; |
292
|
|
|
|
|
|
|
if ( ! @relays ) { |
293
|
|
|
|
|
|
|
$msg .= " * NO RELAYS\n" |
294
|
|
|
|
|
|
|
} else { |
295
|
|
|
|
|
|
|
$msg .= $_->dump_state."\n" for(@relays); |
296
|
|
|
|
|
|
|
} |
297
|
|
|
|
|
|
|
$msg .= "-------- active relays ------------------\n"; |
298
|
|
|
|
|
|
|
my $od = $DEBUG; |
299
|
|
|
|
|
|
|
$DEBUG = 1; |
300
|
|
|
|
|
|
|
debug($msg); |
301
|
|
|
|
|
|
|
$DEBUG = $od; |
302
|
|
|
|
|
|
|
}); |
303
|
|
|
|
|
|
|
|
304
|
|
|
|
|
|
|
while (1) { |
305
|
|
|
|
|
|
|
shift(@once)->() while (@once); |
306
|
|
|
|
|
|
|
$loop = AnyEvent->condvar; |
307
|
|
|
|
|
|
|
$loop->recv; |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
|
|
|
|
|
|
# parent mainloop: keep children running |
312
|
|
|
|
|
|
|
sub parent_loop { |
313
|
|
|
|
|
|
|
my $self = shift; |
314
|
|
|
|
|
|
|
$DEBUG && debug("parent $$"); |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
$SIG{USR1} = sub { |
317
|
|
|
|
|
|
|
my @pid = grep { $_ } @{$self->{childs}} or return; |
318
|
|
|
|
|
|
|
debug("propagating USR1 to @pid"); |
319
|
|
|
|
|
|
|
kill 'USR1', @pid; |
320
|
|
|
|
|
|
|
}; |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
$SIG{USR2} = sub { |
323
|
|
|
|
|
|
|
my @pid = grep { $_ } @{$self->{childs}} or return; |
324
|
|
|
|
|
|
|
my $was_debug = $DEBUG; |
325
|
|
|
|
|
|
|
$DEBUG = 1; |
326
|
|
|
|
|
|
|
debug("propagating USR2 to @pid"); |
327
|
|
|
|
|
|
|
kill 'USR2', @pid; |
328
|
|
|
|
|
|
|
$DEBUG = ! $was_debug; |
329
|
|
|
|
|
|
|
}; |
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
while ( my $ch = $self->{childs} ) { |
332
|
|
|
|
|
|
|
# check if anything needs to be started |
333
|
|
|
|
|
|
|
for(@$ch) { |
334
|
|
|
|
|
|
|
$_ and next; # child is up |
335
|
|
|
|
|
|
|
# start new child |
336
|
|
|
|
|
|
|
defined( my $pid = fork()) or do { |
337
|
|
|
|
|
|
|
warn "fork failed: $!"; |
338
|
|
|
|
|
|
|
sleep(1); |
339
|
|
|
|
|
|
|
next; |
340
|
|
|
|
|
|
|
}; |
341
|
|
|
|
|
|
|
if ( $pid == 0 ) { |
342
|
|
|
|
|
|
|
# child |
343
|
|
|
|
|
|
|
$0 = "[worker] $0"; |
344
|
|
|
|
|
|
|
$self->{childs} = undef; |
345
|
|
|
|
|
|
|
return $self->loop; |
346
|
|
|
|
|
|
|
} |
347
|
|
|
|
|
|
|
$_ = $pid; |
348
|
|
|
|
|
|
|
$DEBUG && debug("(re)starting child, pid=$pid"); |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
# wait for child exit |
351
|
|
|
|
|
|
|
my $pid = waitpid(-1,0) or next; |
352
|
|
|
|
|
|
|
$DEBUG && debug("child $pid exit with code ".($?>>8)); |
353
|
|
|
|
|
|
|
my $ch = $self->{childs} or return; |
354
|
|
|
|
|
|
|
for(@$ch) { |
355
|
|
|
|
|
|
|
$_ = undef,last if $_ == $pid |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
} |
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
} |
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
sub getoptions { |
362
|
|
|
|
|
|
|
my $self = shift; |
363
|
|
|
|
|
|
|
local @ARGV = @_; |
364
|
|
|
|
|
|
|
GetOptions( |
365
|
|
|
|
|
|
|
'h|help' => sub { usage() }, |
366
|
|
|
|
|
|
|
'P|pcapdir=s' => \$self->{pcapdir}, |
367
|
|
|
|
|
|
|
'mitm-ca=s' => \$self->{mitm_ca}, |
368
|
|
|
|
|
|
|
'capath=s' => \$self->{capath}, |
369
|
|
|
|
|
|
|
'no-check-certificate=s' => \$self->{no_check_certificate}, |
370
|
|
|
|
|
|
|
'C|childs=i' => \$self->{childs}, |
371
|
|
|
|
|
|
|
'M|maxconn=i' => \$self->{max_connect_per_child}, |
372
|
|
|
|
|
|
|
'F|filter=s' => sub { |
373
|
|
|
|
|
|
|
if ($_[1] eq '-') { |
374
|
|
|
|
|
|
|
# discard all previously defined |
375
|
|
|
|
|
|
|
@{$self->{filter}} = (); |
376
|
|
|
|
|
|
|
} else { |
377
|
|
|
|
|
|
|
push @{$self->{filter}}, $_[1] |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
}, |
380
|
|
|
|
|
|
|
'imp-ns=s' => sub { |
381
|
|
|
|
|
|
|
if ($_[1] eq '-') { |
382
|
|
|
|
|
|
|
# discard all previously defined |
383
|
|
|
|
|
|
|
@{$self->{impns}} = (); |
384
|
|
|
|
|
|
|
} else { |
385
|
|
|
|
|
|
|
push @{$self->{impns}}, $_[1] |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
}, |
388
|
|
|
|
|
|
|
'l|log:s' => sub { |
389
|
|
|
|
|
|
|
$self->{logrx} = $_[1] |
390
|
|
|
|
|
|
|
? eval { qr/$_[1]/ } || "bad rx $_[1]" |
391
|
|
|
|
|
|
|
: qr/./; |
392
|
|
|
|
|
|
|
}, |
393
|
|
|
|
|
|
|
'd|debug:s' => sub { |
394
|
|
|
|
|
|
|
$DEBUG = 1; |
395
|
|
|
|
|
|
|
if ($_[1]) { |
396
|
|
|
|
|
|
|
my $rx = eval { qr{$_[1]} }; |
397
|
|
|
|
|
|
|
croak("invalid regex '$_[1]' for debugging: $@") if ! $rx; |
398
|
|
|
|
|
|
|
$DEBUG_RX = $rx; |
399
|
|
|
|
|
|
|
} |
400
|
|
|
|
|
|
|
}, |
401
|
|
|
|
|
|
|
'T|trace=s' => sub { |
402
|
|
|
|
|
|
|
$TRACE{$_} = 1 for split(m/,/,$_[1]) |
403
|
|
|
|
|
|
|
}, |
404
|
|
|
|
|
|
|
); |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
my @addr = @ARGV; |
407
|
|
|
|
|
|
|
$self->{addr} or @addr or usage("no listener given"); |
408
|
|
|
|
|
|
|
$self->{addr} = \@addr; |
409
|
|
|
|
|
|
|
1; |
410
|
|
|
|
|
|
|
} |
411
|
|
|
|
|
|
|
|
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
sub usage { |
414
|
|
|
|
|
|
|
my ($msg,$cmd) = @_; |
415
|
|
|
|
|
|
|
$cmd ||= $0; |
416
|
|
|
|
|
|
|
print STDERR "ERROR: $msg\n" if $msg; |
417
|
|
|
|
|
|
|
print STDERR <
|
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
HTTP proxy, which can inspect and modify requests and responses before |
420
|
|
|
|
|
|
|
forwarding using Net::IMP plugins. |
421
|
|
|
|
|
|
|
|
422
|
|
|
|
|
|
|
$cmd Options* [ip:port|ip:port=upstream_ip:port]+ |
423
|
|
|
|
|
|
|
ip:port - listen address(es) for the proxy |
424
|
|
|
|
|
|
|
ip:port=upstream_ip:port - listen adress and upstream proxy |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
Options: |
427
|
|
|
|
|
|
|
-h|--help show usage |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
--mitm-ca ca.pem use given file in PEM format as a Proxy-CA for intercepting |
430
|
|
|
|
|
|
|
SSL connections (e.g. man in the middle). Should include key |
431
|
|
|
|
|
|
|
and cert. |
432
|
|
|
|
|
|
|
--capath P path to file or dir containing CAs, which are used to verify |
433
|
|
|
|
|
|
|
server certificates when intercepting SSL. |
434
|
|
|
|
|
|
|
Tries to use builtin default if not given. |
435
|
|
|
|
|
|
|
--no-check-certificate do not check server certificates when intercepting |
436
|
|
|
|
|
|
|
SSL connections |
437
|
|
|
|
|
|
|
|
438
|
|
|
|
|
|
|
-C|--childs N fork N childs an keep them running, e.g. if one child dies |
439
|
|
|
|
|
|
|
immediatly fork another one. This way one can spread the load |
440
|
|
|
|
|
|
|
over multiple processors (N>1) or just make sure, that child |
441
|
|
|
|
|
|
|
gets restarted on errors (N=1) |
442
|
|
|
|
|
|
|
-M|--maxconn N child will exit (and gets restarted) after N connections |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
-F|--filter F add named IMP plugin as filter, can be used multiple times |
445
|
|
|
|
|
|
|
with --filter mod=args arguments can be given to the filter |
446
|
|
|
|
|
|
|
--imp-ns N perl module namespace, were it will look for IMP plugins. |
447
|
|
|
|
|
|
|
Can be given multiple times. |
448
|
|
|
|
|
|
|
Plugins outside these namespace need to be given with |
449
|
|
|
|
|
|
|
full name. |
450
|
|
|
|
|
|
|
Defaults to App::HTTP_Proxy_IMP, Net::IMP |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
-l|--log [rx] print log messages where category matches rx (default all) |
453
|
|
|
|
|
|
|
|
454
|
|
|
|
|
|
|
# options intended for development and debugging: |
455
|
|
|
|
|
|
|
-P|--pcapdir D save connections as pcap files into D, needs Net::PcapWriter |
456
|
|
|
|
|
|
|
-d|--debug [RX] debug mode, if RX is given restricts debugging to packages |
457
|
|
|
|
|
|
|
matching RX |
458
|
|
|
|
|
|
|
-T|--trace T enable Net::Inspect traces |
459
|
|
|
|
|
|
|
|
460
|
|
|
|
|
|
|
Examples: |
461
|
|
|
|
|
|
|
start proxy at 127.0.0.1:8888 and log all requests to /tmp as pcap files |
462
|
|
|
|
|
|
|
$cmd --filter Net::IMP::SessionLog=dir=/tmp/&format=pcap 127.0.0.1:8888 |
463
|
|
|
|
|
|
|
start proxy at 127.0.0.1:8888 and log all form fields |
464
|
|
|
|
|
|
|
$cmd --filter LogFormData 127.0.0.1:8888 |
465
|
|
|
|
|
|
|
start proxy at 127.0.0.1:8888 with CSRF protection plugin |
466
|
|
|
|
|
|
|
$cmd --filter CSRFprotect 127.0.0.1:8888 |
467
|
|
|
|
|
|
|
start proxy at 127.0.0.1:8888 with CSRF protection plugin, using upstream |
468
|
|
|
|
|
|
|
proxy proxy:8888 |
469
|
|
|
|
|
|
|
$cmd --filter CSRFprotect 127.0.0.1:8888=proxy:8888 |
470
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
USAGE |
472
|
|
|
|
|
|
|
exit(2); |
473
|
|
|
|
|
|
|
} |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
############################################################################ |
476
|
|
|
|
|
|
|
# AnyEvent wrapper to privide Net::IMP::Remote etc with acccess to |
477
|
|
|
|
|
|
|
# IO events |
478
|
|
|
|
|
|
|
############################################################################ |
479
|
|
|
|
|
|
|
package App::HTTP_Proxy_IMP::EventLoop; |
480
|
|
|
|
|
|
|
sub new { bless {},shift } |
481
|
|
|
|
|
|
|
{ |
482
|
|
|
|
|
|
|
my %watchr; |
483
|
|
|
|
|
|
|
sub onread { |
484
|
|
|
|
|
|
|
my ($self,$fh,$cb) = @_; |
485
|
|
|
|
|
|
|
defined( my $fn = fileno($fh)) or die "invalid filehandle"; |
486
|
|
|
|
|
|
|
if ( $cb ) { |
487
|
|
|
|
|
|
|
$watchr{$fn} = AnyEvent->io( |
488
|
|
|
|
|
|
|
fh => $fh, |
489
|
|
|
|
|
|
|
cb => $cb, |
490
|
|
|
|
|
|
|
poll => 'r' |
491
|
|
|
|
|
|
|
); |
492
|
|
|
|
|
|
|
} else { |
493
|
|
|
|
|
|
|
undef $watchr{$fn}; |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
|
|
498
|
|
|
|
|
|
|
{ |
499
|
|
|
|
|
|
|
my %watchw; |
500
|
|
|
|
|
|
|
sub onwrite { |
501
|
|
|
|
|
|
|
my ($self,$fh,$cb) = @_; |
502
|
|
|
|
|
|
|
defined( my $fn = fileno($fh)) or die "invalid filehandle"; |
503
|
|
|
|
|
|
|
if ( $cb ) { |
504
|
|
|
|
|
|
|
$watchw{$fn} = AnyEvent->io( |
505
|
|
|
|
|
|
|
fh => $fh, |
506
|
|
|
|
|
|
|
cb => $cb, |
507
|
|
|
|
|
|
|
poll => 'w' |
508
|
|
|
|
|
|
|
); |
509
|
|
|
|
|
|
|
} else { |
510
|
|
|
|
|
|
|
undef $watchw{$fn}; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
} |
513
|
|
|
|
|
|
|
} |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
sub now { return AnyEvent->now } |
516
|
|
|
|
|
|
|
sub timer { |
517
|
|
|
|
|
|
|
my ($self,$after,$cb,$interval) = @_; |
518
|
|
|
|
|
|
|
return AnyEvent->timer( |
519
|
|
|
|
|
|
|
after => $after, |
520
|
|
|
|
|
|
|
cb => $cb, |
521
|
|
|
|
|
|
|
$interval ? ( interval => $interval ):() |
522
|
|
|
|
|
|
|
); |
523
|
|
|
|
|
|
|
} |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
|
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
1; |
529
|
|
|
|
|
|
|
__END__ |