File Coverage

blib/lib/Net/IdentServer.pm

Criterion	Covered	Total	%
statement	18	91	19.7
branch	0	30	0.0
condition	0	3	0.0
subroutine	6	15	40.0
pod	5	7	71.4
total	29	146	19.8

package Net::IdentServer;

use strict;
use warnings;
use POSIX;
use Carp;
use base qw(Net::Server::Fork);

our $VERSION  = "0.604";

1;

# run {{{
sub run {
    my $this = shift;
    $0 = ref $this;
    $this->SUPER::run( @_ );
}
# }}}

# print_error {{{
sub print_error {
    my $this = shift;
    my $type = lc(pop);
    my @p = @_;
       @p = (0, 0) unless @p == 2;

    my $txt;
    unless( $txt = {'u'=> "UNKNOWN-ERROR", 'h' => "HIDDEN-USER", 'n' => "NO-USER", 'i' => "INVALID-PORT"}->{$type} ) {
        die "bad type given to print_error";
    }

    $this->print_response(@p, "ERROR", $txt);
}
# }}}
# print_response {{{
sub print_response {
    my ($this, $port_on_server, $port_on_client, $os_name, $add_info) = @_;

    $os_name = "USERID : $os_name" unless $os_name eq "ERROR";

    printf '%d , %d : %s : %s'."\x0d\x0a", $port_on_server, $port_on_client, $os_name, $add_info;
}
# }}}
# do_lookup {{{
sub do_lookup {
    my $this = shift;
    my ($local_addr, $local_port, $rem_addr, $rem_port) = @_;

    my $translate_addr = sub { my $a = shift; my @a = (); push @a, $1 while $a =~ m/(..)/g; join(".", map(hex($_), reverse @a)) };
    my $translate_port = sub { hex(shift) };

    my $found = $this->alt_lookup(@_);

    if( $found =~ m/^JP:(.+)/ ) {
        my $name = $1;

        $this->log(1, "lookup from $rem_addr for $local_port, $rem_port: alt string found $name");
        $this->print_response($local_port, $rem_port, "UNIX", $name);

        return;
    }

    if( $found < 0 ) {
        open my $tcp, "<", "/proc/net/tcp" or die "couldn't open proc/net/tcp for read: $!";
        while(<$tcp>) {
            if( m/^\s+\d+:\s+([A-F0-9]{8}):([A-F0-9]{4})\s+([A-F0-9]{8}):([A-F0-9]{4})\s+(\d+)\s+\S+\s+\S+\s+\S+\s+(\d+)/ ) {
                my ($la, $lp, $ra, $rp, $state, $uid) = ($1, $2, $3, $4, $5, $6);

                if( $state == 1 ) {
                    $la = $translate_addr->($la); $lp = $translate_port->($lp);
                    $ra = $translate_addr->($ra); $rp = $translate_port->($rp);

                    if( $local_port eq $lp and $rem_port eq $rp ) {
                        $found = $uid;
                        last;
                    }
                }
            }
        }
        close $tcp;
    }

    if( $found < 0 ) {
        $this->not_found(@_);

        return;
    }

    my $name = getpwuid( $found );
    unless( $name =~ m/\w/ ) {
        # This can happen if a deleted user has a socket open.  'u' might be a better choice.
        # I happen to think hidden user is a nice choice here.

        $this->log(2, "lookup from $rem_addr for $local_port, $rem_port: found uid, but no pwent");
        $this->print_error($local_port, $rem_port, 'h');
        return;
    }

    $this->log(1, "lookup from $rem_addr for $local_port, $rem_port: found $name");
    $this->print_response($local_port, $rem_port, "UNIX", $name);

    return 1;
}
# }}}
# not_found {{{
sub not_found {
    my $this = shift;
    my ($local_addr, $local_port, $rem_addr, $rem_port) = @_;

    $this->log(2, "lookup from $rem_addr for $local_port, $rem_port: not found");
    $this->print_error($local_port, $rem_port, 'n'); # no user for when we find no sockets!
}
# }}}
# alt_lookup {{{
sub alt_lookup {
    return -1;
}
# }}}

# process_request {{{
sub process_request {
    my $this = shift;

    my $master_alarm = alarm 10;
    local $SIG{ALRM} = sub { die "\n" };
    eval {
        while( my $input =  ) {
           $input = "" unless $input; # to deal with stupid undef warning
           $input =~ s/[\x0d\x0a]+\z//;

            unless( $input =~ m/^\s*(\d+)\s*,\s*(\d+)\s*$/ ) {
                $this->log(3, "Malformated request from $this->{server}{peeraddr}");
                $this->print_error("u");
                return;
            }
            my ($s, $c) = ($1, $2);

            $this->do_lookup($this->{server}{sockaddr}, $s, $this->{server}{peeraddr}, $c);
        }
    };
    alarm $master_alarm;

    if( $@ eq "\n" ) {
        # print "500 too slow...\n";
        # on timeout, ident just closes the connection ...

    } elsif( $@ ) {
        $this->log(3, "ERROR during main while() { do_lookup() } eval: $@");

    }
}
# }}}

__END__