view release on metacpan or  search on metacpan

lib/App/HTTP_Proxy_IMP.pm  view on Meta::CPAN

	while (1) {
	    shift(@once)->() while (@once);
	    $loop = AnyEvent->condvar;
	    $loop->recv;
	}
    }

    # parent mainloop: keep children running
    sub parent_loop {
	my $self = shift;
	$DEBUG && debug("parent $$");

	$SIG{USR1} = sub {
	    my @pid = grep { $_ } @{$self->{childs}} or return;
	    debug("propagating USR1 to @pid");
	    kill 'USR1', @pid;
	};

	$SIG{USR2} = sub {
	    my @pid = grep { $_ } @{$self->{childs}} or return;
	    my $was_debug = $DEBUG;
	    $DEBUG = 1;
	    debug("propagating USR2 to @pid");
	    kill 'USR2', @pid;
	    $DEBUG = ! $was_debug;
	};

	while ( my $ch = $self->{childs} ) {
	    # check if anything needs to be started
	    for(@$ch) {
		$_ and next; # child is up
		# start new child
		defined( my $pid = fork()) or do {
		    warn "fork failed: $!";
		    sleep(1);
		    next;
		};
		if ( $pid == 0 ) {
		    # child
		    $0 = "[worker] $0";
		    $self->{childs} = undef;
		    return $self->loop;
		}
		$_ = $pid;
		$DEBUG && debug("(re)starting child, pid=$pid");
	    }
	    # wait for child exit
	    my $pid = waitpid(-1,0) or next;
	    $DEBUG && debug("child $pid exit with code ".($?>>8));
	    my $ch = $self->{childs} or return;
	    for(@$ch) {
		$_ = undef,last if $_ == $pid
	    }
	}
    }
}

sub getoptions {
    my $self = shift;
    local @ARGV = @_;
    GetOptions(
	'h|help'      => sub { usage() },
	'P|pcapdir=s' => \$self->{pcapdir},
	'mitm-ca=s'   => \$self->{mitm_ca},
	'capath=s'    => \$self->{capath},
	'no-check-certificate=s' => \$self->{no_check_certificate},
	'C|childs=i'  => \$self->{childs},
	'M|maxconn=i' => \$self->{max_connect_per_child},
	'F|filter=s'  => sub { 
	    if ($_[1] eq '-') { 
		# discard all previously defined
		@{$self->{filter}} = ();
	    } else {
		push @{$self->{filter}}, $_[1]
	    }
	},
	'imp-ns=s'    => sub {
	    if ($_[1] eq '-') { 
		# discard all previously defined
		@{$self->{impns}} = ();
	    } else {
		push @{$self->{impns}}, $_[1]
	    }
	},
	'l|log:s' => sub {
	    $self->{logrx} = $_[1] 
		? eval { qr/$_[1]/ } || "bad rx $_[1]" 
		: qr/./;
	},
	'd|debug:s' => sub {
	    $DEBUG = 1;
	    if ($_[1]) {
		my $rx = eval { qr{$_[1]} };
		croak("invalid regex '$_[1]' for debugging: $@") if ! $rx;
		$DEBUG_RX = $rx;
	    }
	},
	'T|trace=s' => sub { 
	    $TRACE{$_} = 1 for split(m/,/,$_[1]) 
	},
    );

    my @addr = @ARGV;
    $self->{logrx} //= qr/./;
    $self->{addr} or @addr or usage("no listener given");
    $self->{addr} = \@addr;
    1;
}


sub usage {
    my ($msg,$cmd) = @_;
    $cmd ||= $0;
    print STDERR "ERROR: $msg\n" if $msg;
    print STDERR <<USAGE;

HTTP proxy, which can inspect and modify requests and responses before
forwarding using Net::IMP plugins.

$cmd Options* [ip:port|ip:port=upstream_ip:port]+