File Coverage

blib/lib/App/HTTP_Proxy_IMP.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


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__