#!perl -w

=head1 NAME

p0f - A TCP Fingerprinting Identification Plugin

=head1 SYNOPSIS

Use TCP fingerprint info (remote computer OS, network distance, etc) to
implement more sophisticated anti-spam policies.

=head1 DESCRIPTION

This p0f module inserts a I<p0f> connection note with information deduced
from the TCP fingerprint. The note typically includes at least the link,
detail, distance, uptime, genre. Here's a p0f v2 example:

 genre    => FreeBSD
 detail   => 6.x (1)
 uptime   => 1390
 link     => ethernet/modem
 distance => 17

Which was parsed from this p0f fingerprint:

  24.18.227.2:39435 - FreeBSD 6.x (1) (up: 1390 hrs)
    -> 208.75.177.101:25 (distance 17, link: ethernet/modem)

When using p0f v3, the following additional values may also be available in
the I<p0f> connection note:

=over 4

magic, status, first_seen, last_seen, total_conn, uptime_min, up_mod_days, last_nat, last_chg, distance, bad_sw, os_match_q, os_name, os_flavor, http_name, http_flavor, link_type, and language.

=back

=head1 MOTIVATION

This p0f plugin provides a way to make sophisticated policies for email
messages. For example, the vast majority of email connections to my server
from Windows computers are spam (>99%). But, I have clients with
Exchange servers so I can't block email from all Windows computers.

Same goes for greylisting. Finance companies (AmEx, BoA, etc) send notices
that they don't queue and retry. They deliver immediately or never. Enabling
greylisting means maintaining manual whitelists or losing valid messages.

While I'm not willing to use greylisting for every connection, and I'm not
willing to block connections from Windows computers, I am willing to greylist
all email from Windows computers.

=head1 CONFIGURATION

Configuration consists of two steps: starting p0f and configuring this plugin.

=head2 start p0f

Create a startup script for p0f that creates a communication socket when your
server starts up.

p0f v2 example:

 p0f -u qpsmtpd -d -q -Q /tmp/.p0f_socket2 'dst port 25' -o /dev/null
 chown qpsmtpd /tmp/.p0f_socket2

p0f v3 example:

 p0f -u qpsmtpd -d -s /tmp/.p0f_socket3 'dst port 25'
 chown qpsmtpd /tmp/.p0f_socket3

=head2 configure p0f plugin

add an entry to config/plugins to enable p0f:

 ident/p0f /tmp/.p0f_socket3

It's even possible to run both versions of p0f simultaneously:

 ident/p0f:2 /tmp/.p0f_socket2 version 2
 ident/p0f:3 /tmp/.p0f_socket3

=head2 local_ip

Use I<local_ip> to override the IP address of your mail server. This is useful
if your mail server runs on a private IP behind a firewall. My mail server has
the IP 127.0.0.6, but the world knows my mail server as 208.75.177.101.

Example config/plugins entry with local_ip override:

  ident/p0f /tmp/.p0f_socket local_ip 208.75.177.101


=head2 version

The version settings specifies the version of p0f you are running. This plugin supports p0f versions 2 and 3. If version is not defined, version 3 is assumed.

Example entry specifying p0f version 2

  ident/p0f /tmp/.p0f_socket version 2

=head2 smite_os

Assign -1 karma to senders whose OS match the regex pattern supplied. I only recommend using with this p0f 3, as it's OS database is far more reliable than p0f v2.

Example entry:

  ident/p0f /tmp/.p0f_socket smite_os windows

=head2 add_headers <true|false>

Add message headers with p0f data

  ident/p0f [ add_headers (true|false) ]

Example entry disabling header addition

  ident/p0f /tmp/.p0f_socket add_headers false

Default: true

=head1 CONFIGURATION FILES

=head2 p0f_blocked_operating_systems

If populated, systems that match the phrases and regular expressions
in this list will be rejected.

Regular expressions are case-insensitive.

Example entries:

Windows XP
/windows/

Default: none (p0f rejections disabled)

=head1 Environment requirements

p0f v3 requires only the remote IP.

p0f v2 requires four pieces of information to look up the p0f fingerprint:
local_ip, local_port, remote_ip, and remote_port. TcpServer.pm has been
has been updated to provide that information when running under djb's
tcpserver. The forkserver and prefork models will likely require
some additional changes to make sure these fields are populated.

=head1 ACKNOWLEDGEMENTS

Version 2 code heavily based upon the p0fq.pl included with the p0f distribution.

=head1 AUTHORS

2004 - Robert Spier ( original author )

2010 - Matt Simerson - added local_ip option

2012 - Matt Simerson - refactored, added v3 support

=cut

use strict;
use warnings;

use Qpsmtpd::Constants;
use IO::Socket;
use Net::IP;

my $QUERY_MAGIC_V2 = 0x0defaced;
my $QUERY_MAGIC_V3 = 0x50304601;
my $RESP_MAGIC_V3  = 0x50304602;

my $P0F_STATUS_BADQUERY = 0x00;
my $P0F_STATUS_OK       = 0x10;
my $P0F_STATUS_NOMATCH  = 0x20;

sub register {
    my ($self, $qp, $p0f_socket, %args) = @_;

    $p0f_socket =~ /(.*)/;    # untaint
    $self->{_args}->{p0f_socket} = $1;
    foreach (keys %args) {
        $self->{_args}->{$_} = $args{$_};
    }
    $self->register_headers();
    $self->register_genre_blocking();
}

sub register_headers {
    my ( $self ) = @_;
    my $enabled = $self->{_args}{add_headers};
    $enabled = 'true' if ! defined $enabled;
    return if $enabled =~ /false/i;
    $self->register_hook( data_post => 'add_headers' );
}

sub register_genre_blocking {
    my ( $self ) = @_;
    my @patterns = $self->qp->config('p0f_blocked_operating_systems');
    return unless @patterns;
    for my $pattern ( @patterns ) {
        if ( $pattern =~ /^\/(.*)\/$/ ) {
            push @{ $self->{os_block_re} }, qr/$1/i;
        } else {
            push @{ $self->{os_block} }, $pattern;
        }
    }
    $self->register_hook( rcpt => 'rcpt_handler' );
}

sub rcpt_handler {
    my ( $self, $txn, $rcpt ) = @_;
    return DECLINED if ! $self->check_genre($rcpt);
    return DENY, 'OS Blocked';
}

sub check_genre {
    my ( $self, $rcpt ) = @_;
    my $genre = ( $self->connection->notes('p0f') || {} )->{genre} or return 0;
    return 0 if $self->exclude_connection();
    return 0 if $self->exclude_recipient($rcpt);
    for my $phrase ( @{ $self->{os_block} || [] } ) {
        return 1 if $genre eq $phrase;
    }
    for my $re ( @{ $self->{os_block_re} || [] } ) {
        return 1 if $genre =~ $re;
    }
    return 0;
}

sub exclude_connection {
    my ( $self ) = @_;
    my $cxn = $self->connection;
    return $cxn->notes('p0f_exclude')   if defined $cxn->notes('p0f_exclude');
    return $cxn->notes('p0f_exclude',1) if $self->is_immune();
    return $cxn->notes('p0f_exclude',0);
}

# This sub exists to be overridden by plugins that inherit from this one
sub exclude_recipient  { return 0 }

sub hook_connect {
    my ($self, $qp) = @_;

    my $p0f_version = $self->{_args}{version} || 3;
    if ($p0f_version == 3) {
        my $response = $self->query_p0f_v3() or return DECLINED;
        $self->test_v3_response($response) or return DECLINED;
        $self->store_v3_results($response);
    }
    else {
        my $response = $self->query_p0f_v2() or return DECLINED;
        $self->test_v2_response($response) or return DECLINED;
        $self->store_v2_results($response);
    }

    return DECLINED;
}

sub add_headers {
    my ( $self, $txn ) = @_;
    my $p0f = $self->connection->notes('p0f') or return DECLINED;
    $self->add_p0f_header( 'X-P0F-Genre'     => $p0f->{genre}     );
    $self->add_p0f_header( 'X-P0F-Link-Type' => $p0f->{link_type} );
    return DECLINED;
}

sub add_p0f_header {
    my ( $self, $tag, $value ) = @_;
    return if ! $value;
    $self->transaction->header->delete( $tag );
    $self->transaction->header->add( $tag, $value, 0 );
}

sub get_v2_query {
    my $self = shift;

    my $local_ip = $self->{_args}{local_ip} || $self->qp->connection->local_ip;

    my $src = new Net::IP($self->qp->connection->remote_ip)
      or $self->log(LOGERROR, "skip, " . Net::IP::Error()), return;

    my $dst = new Net::IP($local_ip)
      or $self->log(LOGERROR, "skip, " . NET::IP::Error()), return;

    return
      pack("L L L N N S S",
           $QUERY_MAGIC_V2,
           1,
           rand ^ 42 ^ time,
           $src->intip(),
           $dst->intip(),
           $self->qp->connection->remote_port,
           $self->qp->connection->local_port);
}

sub get_v3_query {
    my $self = shift;

    my $src_ip = $self->qp->connection->remote_ip or do {
        $self->log(LOGERROR, "skip, unable to determine remote IP");
        return;
    };

    if ($src_ip =~ /:/) {    # IPv6
        my @bits = split(/\:/, $src_ip);
        return
          pack("L C C C C C C C C C C C C C C C C C",
               $QUERY_MAGIC_V3, 0x06, @bits);
    }

    my @octets = split(/\./, $src_ip);
    return pack("L C C16", $QUERY_MAGIC_V3, 0x04, @octets);
}

sub query_p0f_v3 {
    my $self = shift;

    my $p0f_socket = $self->{_args}{p0f_socket} or do {
        $self->log(LOGERROR, "skip, socket not defined in config.");
        return;
    };
    my $query = $self->get_v3_query() or return;

    # Open the connection to p0f
    my $sock = IO::Socket::UNIX->new(Peer => $p0f_socket, Type => SOCK_STREAM);
    if (!$sock) {
        $self->log(LOGERROR, "skip, could not open socket: $!");
        return;
    }

    $sock->autoflush(1);    # paranoid redundancy
    $sock->connected or do {
        $self->log(LOGERROR, "skip, socket not connected: $!");
        return;
    };

    my $sent = $sock->send($query, 0) or do {
        $self->log(LOGERROR, "skip, send failed: $!");
        return;
    };

    print $sock $query
      ;    # yes, this is redundant, but I get no response from p0f otherwise

    $self->log(LOGDEBUG, "sent $sent byte request");

    my $response;
    $sock->recv($response, 232);
    my $length = length $response;
    $self->log(LOGDEBUG, "received $length byte response");
    close $sock;
    return $response;
}

sub query_p0f_v2 {
    my $self = shift;

    my $p0f_socket = $self->{_args}->{p0f_socket};
    my $query = $self->get_v2_query() or return;

    # Open the connection to p0f
    socket(SOCK, PF_UNIX, SOCK_STREAM, 0)
      or $self->log(LOGERROR, "socket: $!"), return;
    connect(SOCK, sockaddr_un($p0f_socket))
      or $self->log(LOGERROR, "connect: $! ($p0f_socket)"), return;
    defined syswrite SOCK, $query
      or $self->log(LOGERROR, "write: $!"), close SOCK, return;

    my $response;
    defined sysread SOCK, $response, 1024
      or $self->log(LOGERROR, "read: $!"), close SOCK, return;
    close SOCK;
    return $response;
}

sub test_v2_response {
    my ($self, $response) = @_;

    # Extract part of the p0f response
    my ($magic, $id, $type) = unpack("L L C", $response);

    # $self->log(LOGERROR, $response);
    if ($magic != $QUERY_MAGIC_V2) {
        $self->log(LOGERROR, "skip, Bad response magic.");
        return;
    }

    if ($type == 1) {
        $self->log(LOGERROR, "skip, p0f did not honor our query");
        return;
    }
    elsif ($type == 2) {
        $self->log(LOGWARN, "skip, connection not in the cache");
        return;
    }
    return 1;
}

sub test_v3_response {
    my ($self, $response) = @_;

    my ($magic, $status) = unpack("L L", $response);

    # check the magic response value (a p0f constant)
    if ($magic != $RESP_MAGIC_V3) {
        $self->log(LOGERROR, "skip, Bad response magic.");
        return;
    }

    # check the response status
    if ($status == $P0F_STATUS_BADQUERY) {
        $self->log(LOGERROR, "skip, bad query");
        return;
    }
    elsif ($status == $P0F_STATUS_NOMATCH) {
        $self->log(LOGINFO, "skip, no match");
        return;
    }
    if ($status == $P0F_STATUS_OK) {
        $self->log(LOGDEBUG, "pass, query ok");
        return 1;
    }
    return;
}

sub store_v2_results {
    my ($self, $response) = @_;

    my (
        $magic, $id, $type, $genre, $detail, $dist,   $link,
        $tos,   $fw, $nat,  $real,  $score,  $mflags, $uptime
       )
      = unpack("L L C Z20 Z40 c Z30 Z30 C C C s S N", $response);

    my $p0f = {
               genre    => $genre,
               detail   => $detail,
               distance => $dist,
               link     => $link,
               uptime   => $uptime,
              };

    $self->connection->notes('p0f', $p0f);
    $self->log(LOGINFO, $genre . " (" . $detail . ")");
    $self->log(LOGERROR, "error: $@") if $@;
    return $p0f;
}

sub store_v3_results {
    my ($self, $response) = @_;

    my @labels = qw/ magic status first_seen last_seen total_conn uptime_min
      up_mod_days last_nat last_chg distance bad_sw os_match_q os_name os_flavor
      http_name http_flavor link_type language /;
    my @values =
      unpack("L L L L L L L L L s C C A32 A32 A32 A32 A32 A32 A32", $response);

    my %r;
    foreach my $i (0 .. (scalar @labels - 1)) {
        next if !defined $values[$i];
        next if !defined $values[$i];
        $r{$labels[$i]} = $values[$i];
    }
    if ($r{os_name}) {    # compat with p0f v2
        $r{genre}  = "$r{os_name} $r{os_flavor}";
        $r{link}   = $r{link_type} if $r{link_type};
        $r{uptime} = $r{uptime_min} if $r{uptime_min};
    }

    if ($r{genre} && $self->{_args}{smite_os}) {
        my $sos = $self->{_args}{smite_os};
        $self->adjust_karma(-1) if $r{genre} =~ /$sos/i;
    }
    $self->connection->notes('p0f', \%r);
    $self->log(LOGINFO,  "$r{os_name} $r{os_flavor}");
    $self->log(LOGDEBUG, join(' ', @values));
    $self->log(LOGERROR, "error: $@") if $@;
    return \%r;
}