view release on metacpan or  search on metacpan

lib/Apache/HTTunnel/Handler.pm  view on Meta::CPAN

		my @params = split(/\//, $path_info) ;
	
		my $cmd = shift @params ;
		$slog->info("HTTunnel Handler: Processing '$cmd' command ($path_info)") ;
		if ($cmd eq 'connect'){
			($resp, $timeout, $extra) = connect_cmd($r, @params) ;
		}
		elsif ($cmd eq 'read'){
			($resp, $timeout, $extra) = read_cmd($r, @params) ;
		}
		elsif ($cmd eq 'write'){
			($resp, $timeout, $extra) = write_cmd($r, @params) ;
		}
		elsif ($cmd eq 'close'){
			($resp, $timeout, $extra) = close_cmd($r, @params) ;
		}
		else {
			die("Invalid command $cmd ($path_info)") ;
		}
	} ;
	if ($@){
		# TODO: Handle APR::Error
		$resp = 'err'. $@ ;
		$slog->error("HTTunnel Handler: $@") ;
	}
	else {
		if (defined($extra)){
			$extra .= ':' ;
		}
		if ($timeout){
			$resp = 'okt' . $extra ;
		}
		elsif (length($resp) == 0){
			$resp = 'okn' . $extra ;
		}
		else {
			$resp = 'okd' . $extra . $resp ;
		}
	}

	$r->print($resp) or
		$slog->error("HTTunnel Handler: Error writing response to client: $!") ;
	$r->rflush() ;

	my $cnt = $fdk->cnt() ;
	$slog->info("HTTunnel Handler: $cnt handles remaining in Keeper") ;

	return OK ;
}


sub connect_cmd {
	my $r = shift ;
	my @params = @_ ;

	my $slog = $r->log() ;
	my $proto = shift @params ;
	my $host = shift @params ;
	my $port = shift @params ;
	my $timeout = shift @params || 15 ;
	my $max_timeout = $r->dir_config('HTTunnelMaxConnectTimeout') || 15 ;
	if ($timeout > $max_timeout){
		$slog->notice("HTTunnel Handler: Requested connect timeout ($timeout) decreased " .
			"to HTTunnelMaxConnectTimeout ($max_timeout)") ;
		$timeout = $max_timeout ;
	}

	check_access($r, $host, $port) ;
	$slog->info("HTTunnel Handler: Connecting to $host:$port...") ;

	my $sock = undef ;
	my $peer_info = undef ;
	eval {
		local $SIG{ALRM} = sub {die "timeout\n"} ;
		alarm($timeout) ;
		$sock = new IO::Socket::INET(
			Proto => $proto,
			PeerAddr => $host,
			PeerPort => $port,
		) ;
		die("Error connecting to $host:$port: $!") unless defined($sock) ;

		if ($proto eq 'tcp'){
			my $peer = getpeername($sock) ;
			my ($port, $addr) = sockaddr_in($peer) ;
			$peer_info = join(':', inet_ntoa($addr), $port) ;
		}

		alarm(0) ;
	} ;
	if ($@){
		if ($@ eq "timeout\n"){
			$slog->notice("HTTunnel Handler: Connection to $host:$port timed out " .
				"after $timeout seconds.") ;
			return (undef, 0) ;
		}
		else {
			alarm(0) ;
			die("$@\n") ;
		}
	}

	die("Can't connect to $host:$port: $!") unless $sock ;
	$slog->notice("HTTunnel Handler: Connected to $host:$port") ;

	$slog->notice("HTTunnel Handler: Putting filehandle...") ;
	my $fhid = $fdk->put($sock) ;
	$slog->notice("HTTunnel Handler: Filehandle '$fhid' put") ;

	return ($fhid, 0, $peer_info) ;
}


sub check_access {
	my $r = shift ;
	my $host = shift ;
	my $port = shift ;

	my $slog = $r->log() ;
	my $rules = $r->dir_config('HTTunnelAllowedTunnels') or die("HTTunnelAllowedTunnels not defined in Apache configuration file") ;
	$rules =~ s/^\s+// ;
	$rules =~ s/\s+$// ;
	my @rules = split(/\s*,\s*/, $rules) ;
	foreach my $r (@rules){
		$slog->debug("HTTunnel Handler: Allowed (raw): $r") ;
	}

	my %allowed = () ;
	foreach my $r (@rules){
		my ($hosts, $ports) = split(/\s*=>\s*/, $r) ;
		my @hosts = split(/\s*\|\s*/, $hosts) ;
		my @ports = split(/\s*\|\s*/, $ports) ;

		foreach my $h (@hosts){
			foreach my $p (@ports){
				my @addrs = ($h) ;
				if ($h ne '*'){
					my @info = gethostbyname($h) ;
					for (my $i = 4 ; $i < scalar(@info) ; $i++){
						push @addrs, inet_ntoa($info[$i]) ;
					}
				}
				foreach my $a (@addrs){
					$allowed{"$a:$p"} = 1 ;
				}
			}
		}
	}
	foreach my $r (@rules){
		$slog->debug("HTTunnel Handler: Allowed (expanded): $r") ;
	}

	if (($allowed{"$host:$port"})||($allowed{"$host:*"})||
		($allowed{"*:$port"})||($allowed{"*:*"})){
		$slog->notice("HTTunnel Handler: $host:$port is allowed by configuration") ;
	}
	else{
		die("Permission denied for $host:$port") ;
	}
}


sub read_cmd {
	my $r = shift ;
	my @params = @_ ;

	my $slog = $r->log() ;
	my $fhid = shift @params ;
	my $proto = shift @params ;
	my $len = shift @params ;
	my $timeout = shift @params || 15 ;
	my $max_len = $r->dir_config('HTTunnelMaxReadLength') || 131072 ;
	if ($len > $max_len){
		$slog->notice("HTTunnel Handler: Requested read length ($len) decreased " .
			"to HTTunnelMaxReadLength ($max_len)") ;
		$len = $max_len ;
	}
	my $max_timeout = $r->dir_config('HTTunnelMaxReadTimeout') || 15 ;
	if ($timeout > $max_timeout){
		$slog->notice("HTTunnel Handler: Requested read timeout ($timeout) decreased " .
			"to HTTunnelMaxReadTimeout ($max_timeout)") ;
		$timeout = $max_timeout ;
	}

	my $data = undef ;
	$slog->notice("HTTunnel Handler: Getting filehandle '$fhid'...") ;
	my $fh = $fdk->get($fhid) or die("Unknown filehandle '$fhid'") ;
	$slog->notice("HTTunnel Handler: Filehandle '$fhid' gotten") ;

	my $timed_out = 0 ;
	my $peer_info = undef ;
	eval {
		local $SIG{ALRM} = sub {die "timeout\n"} ;
		alarm($timeout) ;
		$slog->info("HTTunnel Handler: Reading up to $len bytes from filehandle '$fhid'") ;
		if ($proto eq 'udp'){
			my $peer = undef ;
			($peer, $data) = recv_from($fh, $len) ;
			my ($port, $addr) = sockaddr_in($peer) ;
			$peer_info = join(':', inet_ntoa($addr), $port) ;
		}
		else{
			$data = read_from($fh, $len) ;
		}
		if (! defined($data)){
			$slog->notice("HTTunnel Handler: EOF detected on filehandle '$fhid'") ;
		}
		else {
			my $l = length($data) ;
			$slog->notice("HTTunnel Handler: Read $l bytes from filehandle '$fhid'") ;
		}

		alarm(0) ;
	} ;
	if ($@){
		if ($@ eq "timeout\n"){
			$slog->notice("HTTunnel Handler: Read timed out on purpose after $timeout seconds.") ;
			$timed_out = 1 ;
		}
		else {
			alarm(0) ;
			die("$@\n") ;
		}
	}

	return ($data, $timed_out, $peer_info) ;	
}


sub write_cmd {
	my $r = shift ;
	my @params = @_ ;

	my $slog = $r->log() ;
	my $fhid = shift @params ;
	my $proto = shift @params ;

	my $cl = $r->headers_in->{'Content-Length'} ;
	defined($cl) or die("Content-Length is not defined") ;
	$slog->notice("HTTunnel Handler: Content-Length is $cl bytes") ;
	my $data = '' ;