#!/usr/bin/perl -sw

eval 'exec /usr/local/bin/perl -sw -S $0 ${1+"$@"}'
    if 0; # not running under some shell

# simple forking daemon to provide SPF services
# mengwong+spf@pobox.com
# Tue Oct 28 00:46:44 EST 2003
# 
# if you're reading source code, you should probably be on spf-devel@listbox.com.
# 
# echo "ip=IP\nhelo=HELOHOST\nsender=EMAILADDRESS\n" | nc localhost 5970
#
# or use Mail::Postfix::Attr to query spfd over a unix domain socket.
#
# SYNOPSIS
#    spfd [OPTION]...
#
# DEFAULT
#    spfd -port=5970
#
# OPTIONS
#    -port=PORTNUM
#        Listen with a tcp socket on port PORTNUM (mutually exlusive with -path)
#
#    -path=FILESPEC
#        Listen with a unix socket at FILESPEC (mutually exlusive with -port)
#
#    -pathuser=USER
#        When using a unix socket set owner to USER
#
#    -pathgroup=GROUP
#        When using a unix socket set group to GROUP
#
#    -pathmode=MODE
#        When using a unix socket set socket permissions to MODE (octal)
#
#    -setuser=(uid|username)
#        Drop privileges to uid or username after opening the socket
#
#    -setgroup=(gid|groupname)
#        Drop privileges to gid or groupname after opening the socket
#

# example usage
#    
#    20040113-22:39:24 mengwong@dumbo:~% echo "ip=208.210.125.24\nhelo=moo.com\nsender=mengwong@vw.mailzone.com\n" | nc localhost 5970
#    result=fail
#    smtp_comment=please see http://spf.pobox.com/why.html?sender=mengwong%40vw.mailzone.com&ip=208.210.125.24&receiver=dumbo.pobox.com
#    header_comment=dumbo.pobox.com: domain of mengwong@vw.mailzone.com does not designate 208.210.125.24 as permitted sender
#    guess=pass
#    smtp_guess=vw.mailzone.com MX dumbo.pobox.com A 208.210.125.24
#    header_guess=seems reasonable for mengwong@vw.mailzone.com to mail through 208.210.125.24
#    guess_tf=pass
#    smtp_tf=dumbo.pobox.com.wl.trusted-forwarder.org found
#    header_tf=seems reasonable for mengwong@vw.mailzone.com to mail through 208.210.125.24
#    spf_record=v=spf1 mx:vw.com ptr:vw.com ptr:monkey.org -all
# 
#  the three sets of results correspond to ->result(), ->best_guess(), and ->trusted_forwarder()
#  in Mail::SPF::Query.
# 

use Mail::SPF::Query;
use Socket;

use strict;
use vars qw($port $path $pathuser $pathgroup $pathmode $setuser $setgroup);

# FIXME
sub usage () {
  print "usage: spfd ( -port=5970 | -path=/var/spfd ) [-setuser=(uid|username)] [-setgroup=(gid|groupname)]\n";
  print "usage:      [ -pathuser=(uid|username)] [ -pathgroup=(gid|groupname)] [-pathmode=mode]\n";
  print "usage: spfd assuming -port=5970\n";
}

sub DEBUG () { $ENV{DEBUG} }

if (not $port and not $path) {
  usage;
  $port=5970;
}

if ($port and $path) {
  usage;
  exit 1;
}

$|++;

my @args;
my $sock_type;

if ($port) {
  $sock_type = "inet";
  @args = (Listen    => 1,
	   LocalAddr => "127.0.0.1",
	   LocalPort => $port,
	   ReuseAddr => 1
	   );
  print "$$ will listen on $port\n";
  $0 = "spfd listening on $port";
} elsif ($path) {
  $sock_type = "unix";
  unlink $path if -S $path;
  @args = (Listen => 1,
	   Local => $path,
	   );
  print "$$ will listen at $path\n";
  $0 = "spfd listening at $path";
}

print "$$: creating server with args @args\n";

my $server = $sock_type eq "inet" ? IO::Socket::INET->new(@args) : IO::Socket::UNIX->new(@args);

if ($path) {
  if (defined $pathuser or defined $pathgroup) {
    unless ( defined $pathuser ) { $pathuser = -1 }
    unless ( defined $pathgroup ) { $pathgroup = -1 }

    if ($pathuser =~ /\D/) {
      $pathuser = getpwnam($pathuser) || die "User: $pathuser not found\n";
    }

    if ($pathgroup =~ /\D/) {
      $pathgroup = getgrnam($pathgroup) || die "Group: $pathgroup not found\n";
    }

    chown $pathuser, $pathgroup, $path or die "chown call failed on $path: $!\n";
  }
  if (defined $pathmode) {
    chmod oct($pathmode), $path or die "Cannot fixup perms on $path -- $!\n";
  }
}

DEBUG and print "$$: server is $server\n";

if ($setgroup) {
  if ($setgroup =~ /\D/) {
    $setgroup = getgrnam($setgroup) || die "Group: $setgroup not found\n";
  }
  $( = $setgroup;
  $) = $setgroup;
  unless ($( == $setgroup and $) == $setgroup) {
    die( "setgid($setgroup) call failed: $!\n" );
  }
}

if ($setuser) {
  if ($setuser =~ /\D/) {
    $setuser = getpwnam($setuser) || die "User: $setuser not found\n"; 
  }
   $< = $setuser;
   $> = $setuser;
   unless ($< == $setuser and $> == $setuser) {
    die( "setuid($setuser) call failed: $!\n" );
  }
}

while (my $sock = $server->accept()) {
  if    (fork) { close $sock; wait; next; } # this is the grandfather trick.
  elsif (fork) {                    exit; } # the child exits immediately, so no zombies.

  my $oldfh = select($sock); $| = 1; select($oldfh);

  my %in;

  while (<$sock>) {
    chomp; chomp;
    last if (/^$/);
    my ($lhs, $rhs) = split /=/, $_, 2;
    $in{lc $lhs} = $rhs;
  }

  my $peerinfo = $sock_type eq "inet" ? ($sock->peerhost . "/" . gethostbyaddr($sock->peeraddr, AF_INET)) : "";

  my $time = localtime;
  
  DEBUG and print "$time $peerinfo\n";
  foreach my $key (sort keys %in) { DEBUG and print "learned $key = $in{$key}\n" };

  my %q = map { exists $in{$_} ? ($_ => $in{$_}) : () } qw ( ip ipv4 ipv6 sender helo fallbacks guess_mechs );

  my %a;

  my $query = eval { Mail::SPF::Query->new(%q); };

  my $error = $@; for ($error) { s/\n/ /; s/\s+$//; }

  if ($@) { @a{qw(result smtp_comment header_comment)} = ("unknown", $error, "SPF error: $error"); }
  else {
    @a{qw(result    smtp_comment header_comment spf_record)} = $query->result();
    @a{qw(guess     smtp_guess   header_guess  )} = $query->best_guess();
    @a{qw(guess_tf  smtp_tf      header_tf     )} = $query->trusted_forwarder();
  }

  if (DEBUG) {
    for (qw(result    smtp_comment header_comment
	    guess     smtp_guess   header_guess
            guess_tf  smtp_tf      header_tf
	    spf_record
	    )) {
      print "moo!  $_=$a{$_}\n";
    }
  }

  for (qw(result    smtp_comment header_comment
	  guess     smtp_guess   header_guess
          guess_tf  smtp_tf      header_tf
	  spf_record
	  )) {
    no warnings 'uninitialized';
    print $sock "$_=$a{$_}\n";
  }

  DEBUG and print "moo!  output all done.\n";
  print $sock "\n";
  DEBUG and print "\n";

  close $sock;

  exit;
}