view release on metacpan or  search on metacpan

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

}

# fatal problem - close connection
sub fatal {
    my ($self,$reason) = @_;
    warn "[fatal] ".( $self->{conn} && $self->{conn}->id || 'noid')." $reason\n";
    $self->close;
    return 0;
}

sub connect:method {
    my ($self,$to,$host,$port,$callback,$reconnect) = @_;
    my $fo = $self->{fds}[$to] ||= App::HTTP_Proxy_IMP::Relay::FD->new($to,undef,$self);
    $fo->connect($host,$port,$callback,$reconnect);
}

# masks/unmasks fd for dir, rw = r|w
sub mask {
    my ($self,$dir,$rw,$v) = @_;
    my $fd = $self->{fds}[$dir] or do {
	warn "fd dir=$dir does not exists\n";
	return;
    };
    $fd->mask($rw,$v);
}

sub fd {
    my ($self,$dir) = @_;
    return $self->{fds}[$dir];
}

# send some data via fd dir
sub forward {
    my ($self,$from,$to,$data) = @_;
    my $fo = $self->{fds}[$to] or return
	$self->fatal("cannot write to $to - no such fo");
    $self->xdebug("$from>$to - forward %d bytes",length($data));
    $fo->write($data,$from);
}

# ssl interception, e.g. upgrade both client and server to SSL sockets,
# where I can read/write unencrypted data
sub sslify {
    my ($self,$from,$to,$hostname,$callback) = @_;
    my $conn = $self->{conn} or return;
    my $mitm = $conn->{mitm} or return; # no MITM needed

    # destroy the current connection object and create a new obne
    $conn = $self->{conn} = $conn->clone;
    $conn->{intunnel} = 1;
    
    my $sfo = $self->{fds}[$from] or return
	$self->fatal("cannot startssl $from - no such fo");

    # stop handling all data
    $self->mask($to,r=>0);
    $self->mask($from,r=>0);
    weaken( my $wself = $self );

    my %sslargs = (
	SSL_verifycn_name => $hostname,
	SSL_verifycn_schema => 'http',
	SSL_hostname => $hostname, # SNI
	$conn->{capath} ? (
	    SSL_verify_mode => SSL_VERIFY_PEER,
	    ( -d $conn->{capath} ? 'SSL_ca_path' : 'SSL_ca_file' ), 
	    $conn->{capath}
	):( 
	    SSL_verify_mode => SSL_VERIFY_NONE 
	)
    );
    $sfo->startssl( %sslargs, sub {
	my $sfo = shift;
	my ($cert,$key) = $mitm->clone_cert($sfo->{fd}->peer_certificate);
	my $cfo = $wself->{fds}[$to] or return
	    $wself->fatal("cannot startssl $to - no such fo");
	$cfo->startssl(
	    SSL_server => 1,
	    SSL_cert => $cert,
	    SSL_key  => $key,
	    sub {
		# allow data again
		$self->mask($to,r=>1);
		$self->mask($from,r=>1);
		$callback->() if $callback;
	    }
	);
    });
}

# closes relay
sub close:method {
    my $self = shift;
    #debug("close $self");
    undef $self->{conn};
    @relays = grep { !$_ or $_ != $self } @relays;
    $_ && $_->close for @{$self->{fds}};
    @{$self->{fds}} = ();
}

# shutdown part of relay
sub shutdown:method {
    my ($self,$dir,$rw,$force) = @_;
    my $fo = $self->{fds}[$dir] or return;
    $fo->shutdown($rw,$force);
}

# check for condition, where we cannot transfer anymore data:
# - nowhere to read and no open requests
# - nowhere to write too
sub closeIfDone {
    my $self = shift;
    my $sink = my $drain = '';
    for my $fo (@{$self->{fds}}) {
	$fo && $fo->{fd} or next;
	return if $fo->{rbuf} ne ''; # has unprocessed data
	return if $fo->{wbuf} ne ''; # has unwritten data
	$drain .= $fo->{dir} if not $fo->{status} & 0b100; # not read-closed
	$sink  .= $fo->{dir} if not $fo->{status} & 0b010; # not write-closed
    }

    if ( $sink eq '' ) {      # nowhere to write
	$DEBUG && $self->xdebug( "close relay because all fd done sink='$sink' ");
	# close relay
	return $self->close;
    }

    if ( $drain ne '01' ) {  # no reading from both sides
	my $conn = $self->{conn};

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

	$self->{relay} or return; # relay already closed
	if ( my $addr = shift ) {
	    tcp_connect($addr,$port, sub {
		if ( my $fd = shift ) {
		    $self->{relay} or return; # relay already closed
		    $self->{fd} = $fd;
		    $self->{status} = 0b001;
		    $self->{host} = "$host.$port";
		    $self->xdebug("connect done");
		    $self->mask( r => 1 );
		    $callback->();
		} else {
		    App::HTTP_Proxy_IMP::Relay::DNS::uncache($host,$addr);
		    $self->{relay} or return; # relay already closed
		    $self->{relay}->fatal("connect to $host.$port failed: $!");
		}
	    });
	} else {
	    $self->{relay}->fatal(
		"connect to $host.$port failed: no such host (DNS)");
	}
    });
    return -1;
}

sub startssl {
    my $self = shift;
    $self->{rbuf} eq '' or return 
	$self->{relay}->fatal("read buf $self->{dir} not empty before starting SSL: '$self->{rbuf}'");
    $self->{wbuf} eq '' or return 
	$self->{relay}->fatal("write buf $self->{dir} not empty before starting SSL: '$self->{wbuf}'");

    my $callback = @_%2 ? pop(@_):undef;
    my %sslargs = @_;
    IO::Socket::SSL->start_SSL( $self->{fd},
	%sslargs,
	SSL_startHandshake => 0,
    ) or die "failed to upgrade socket to SSL";
    my $sub = $sslargs{SSL_server} 
	? \&IO::Socket::SSL::accept_SSL
	: \&IO::Socket::SSL::connect_SSL;
    _ssl($self,$sub,$callback,\%sslargs);
}

sub _ssl {
    my ($self,$sub,$cb,$sslargs) = @_;
    if ( $sub->($self->{fd}) ) {
	$self->xdebug("ssl handshake success");
	$cb->($self) if $cb;
    } elsif ( $!{EAGAIN} ) {
	# retry
	my $dir = 
	    $SSL_ERROR == SSL_WANT_READ ? 'r' :
	    $SSL_ERROR == SSL_WANT_WRITE ? 'w' :
	    return $self->{relay}->fatal( "unhandled $SSL_ERROR on EAGAIN" );
	$self->mask( $dir => sub { _ssl($self,$sub,$cb,$sslargs) });
    } elsif ( $sslargs->{SSL_server} ) {
	return $self->{relay}->fatal( "error on accept_SSL: $SSL_ERROR|$!" );
    } else {
	return $self->{relay}->fatal( 
	    "error on connect_SSL to $sslargs->{SSL_verifycn_name}: $SSL_ERROR|$!" );
    }
}


############################################################################
# DNS cache
############################################################################

package App::HTTP_Proxy_IMP::Relay::DNS;
use AnyEvent::DNS;
use Socket qw(AF_INET AF_INET6 inet_pton);

my %cache;
sub uncache {
    my ($host,$addr) = @_;
    my $e = $cache{lc($host)} or return;
    @$e = grep { $_ ne $addr } @$e;
    delete $cache{lc($host)} if !@$e;
}

sub lookup {
    my ($host,$cb) = @_;
    $host = lc($host);

    if ( my $e = $cache{$host} ) {
	return $cb->(@$e);
    } elsif ( inet_pton(AF_INET,$host) || inet_pton(AF_INET6,$host) ) {
	return $cb->($host);
    }

    AnyEvent::DNS::a($host,sub {
	if ( @_ ) {
	    $cache{$host} = [ @_ ];
	    return $cb->(@_);
	}

	# try AAAA
	AnyEvent::DNS::aaaa($host,sub {
	    $cache{$host} = [ @_ ] if @_;
	    return $cb->(@_);
	});
    });
}

1;