package probes::TCPPing;

=head1 NAME

probes::TCPPing - TCPPing Probe for SmokePing

=head1 SYNOPSIS

 *** Probes ***
 + TCPPing
 binary = /usr/bin/tcpping
 forks = 10

 ++ PROBE_CONF
 port = 80

=head1 DESCRIPTION

Integrates TCPPing as a probe into smokeping. The variable B<binary> must
point to your copy of the TCPPing program. If it is not installed on
your system yet, you can get it from http://www.vdberg.org/~richard/tcpping.
You can also get it from http://www.darkskies.za.net/~norman/scripts/tcpping.

The (optional) port option lets you configure the port for the pings sent.
The TCPPing manpage has the following to say on this topic:

The problem is that with the widespread use of firewalls on the modern Internet,
many of the packets that traceroute(8) sends out end up being filtered, 
making it impossible to completely trace the path to the destination. 
However, in many cases, these firewalls will permit inbound TCP packets to specific 
ports that hosts sitting behind the firewall are listening for connections on. 
By sending out TCP SYN packets instead of UDP or ICMP ECHO packets, 
tcptraceroute is able to bypass the most common firewall filters.

It is worth noting that tcptraceroute never completely establishes a TCP connection 
with the destination host. If the host is not listening for incoming connections, 
it will respond with an RST indicating that the port is closed. If the host instead 
responds with a SYN|ACK, the port is known to be open, and an RST is sent by 
the kernel tcptraceroute is running on to tear down the connection without completing 
three-way handshake. This is the same half-open scanning technique that nmap(1) uses 
when passed the -sS flag.

=item forks

The number of concurrent processes to be run. See probes::basefork(3pm)
for details.

=head1 AUTHOR

Norman Rasmussen <norman@rasmussen.org>

=cut

use strict;
use base qw(probes::basefork);
use IPC::Open3;
use Symbol;
use Carp;

sub new($$$)
{
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self = $class->SUPER::new(@_);

    # no need for this if we run as a cgi
    unless ( $ENV{SERVER_SOFTWARE} ) {
        croak "ERROR: TCPPing port must be between 0 and 65535"
           if $self->{properties}{port} and 
              ( $self->{properties}{port} < 0 or $self->{properties}{port} > 65535 ); 

        croak "ERROR: TCPPing 'binary' not defined in TCPPing probe definition"
            unless defined $self->{properties}{binary};

        croak "ERROR: TCPPing 'binary' does not point to an executable"
            unless -f $self->{properties}{binary} and -x $self->{properties}{binary};
    
        my $return = `$self->{properties}{binary} -C -x 1 localhost 2>&1`;
        croak "ERROR: TCPPing must be installed setuid root or it will not work\n" 
            if $return =~ m/only.+root/;

        if ($return =~ m/bytes, ([0-9.]+)\sms\s+.*\n.*\n.*:\s+([0-9.]+)/ and $1 > 0){
            $self->{pingfactor} = 1000 * $2/$1;
            print "### tcpping seems to report in ", $1/$2, " milliseconds\n";
        } else {
            $self->{pingfactor} = 1000; # Gives us a good-guess default
            print "### assuming you are using an tcpping copy reporting in milliseconds\n";
        }
    };

    return $self;
}

sub ProbeDesc($){
    my $self = shift;
    return "TCP Pings";
}

sub pingone ($){
    my $self = shift;
    my $target = shift;
    # do NOT call superclass ... the ping method MUST be overwriten
    my $inh = gensym;
    my $outh = gensym;
    my $errh = gensym;

    my @times; # Result times

    my @port = () ;
    push @port, $target->{vars}{port} if $target->{vars}{port};

    my @cmd = (
                    $self->{properties}{binary},
                    '-C', '-x', $self->pings($target), 
                    $target->{addr}, @port);
    $self->do_debug("Executing @cmd");
    my $pid = open3($inh,$outh,$errh, @cmd);
    while (<$outh>){
        chomp;
        next unless /^\S+\s+:\s+[\d\.]/; #filter out error messages from tcpping
        @times = split /\s+/;
        my $ip = shift @times;
        next unless ':' eq shift @times; #drop the colon

        @times = map {sprintf "%.10e", $_ / $self->{pingfactor}} sort {$a <=> $b} grep /^\d/, @times;
    }
    waitpid $pid,0;
    close $inh;
    close $outh;
    close $errh;

    return @times;
}

1;