gkn-milter

#!/usr/bin/env perl
use strict;
use Sendmail::PMilter qw(
        :all
);
use Sys::Syslog;

use constant DEBUGGING => 1;

# Blocking reason codes:
# Reason 1: Sender and Recipient are the same.
# Reason 2: Sender claims to be from gknstl.com
# Reason 3: Recipient is gknstl.com
# Reason 4: Sender is null.
# Reason 5: Sender is simply user@domain.com

my $milter = new Sendmail::PMilter;

my $milter_callbacks = {
    'helo' => \&helo_callback,
    'envfrom' => \&envfrom_callback,
    'envrcpt' => \&envrcpt_callback,
};


sub helo_callback{
    my $ctx = shift;
    my $helo = shift;
    
    # Just store the helo and move on.
    # I'm not using it right now, but at some point I might choose
    # to keep a database log of which helo's are spammers.
    my $private = {
        'helo' => $helo
    };

    $ctx->setpriv($private);
    return(SMFIS_CONTINUE);
}
# This gets run when the sender identifies themselves with an e-mail address.
# This is the first things that comes after the ehlo (or helo).
sub envfrom_callback {
    my $ctx = shift;
    my $sender = shift;
    syslog("info","Entered envfrom callback.") if DEBUGGING;

    my $private = $ctx->getpriv();

    # Clean up the sender address
    # Remove any newlines or whitespace.
    chomp($sender);
    $sender =~ s/\s//g;
    
    # Make sure it is 100% lowercased.
    $sender = lc($sender);
    
    # Remove anything before the opening carat, if anything.
    $sender =~ s/^.*?</</;
    
    syslog("info","Got the sender: $sender") if DEBUGGING;

    # Kill the message if it claims to come from gknstl.com...
    if($sender =~ /\@gknstl\.com/){
        # Set a proper reply and reject the message before the body even comes through.
        syslog("warning","Sender claims to be from gknstl.com.  DIE!");
        $ctx->setreply('550','5.7.1',"Blocked by GKN Milter, reason 2");
        return(SMFIS_REJECT); 
    }
    # Kill the message if it claims to be from user@domain.com
    if($sender =~ /user\@domain\.com/){
        # Set a proper reply and reject the message before the body even comes through.
        syslog("warning","Sender claims to be from user\@domain.com.  DIE!");
        $ctx->setreply('550','5.7.1',"Blocked by GKN Milter, reason 5");
        return(SMFIS_REJECT); 
    }
    # Kill the message if the sender is null (aside from <>)
    my $sender_test = $sender;

    # Remove any spaces, greater than or less than.
    $sender_test =~ s/(<|>|\s)//g;
    unless($sender_test){
        # Set a proper reply and reject the message before the body even comes through.
        syslog("warning","Sender is null.  Kill it.");
        $ctx->setreply('550','5.7.1',"Blocked by GKN Milter, reason 4");
        return(SMFIS_REJECT);
    }

    # Store our sender name to pass into the next loop.
    # We can't use global values, as each part of the message can
    # be handled by a different process.
    $private->{'sender'} = $sender;

    # $ctx can assign data to private memory readable by all milter processes.
    # This is how we can pass data along to the next part of the milter.
    $ctx->setpriv($private);

    syslog("info","Assigned the sender to private data.  Continuing.") if DEBUGGING;

    # Return the continue code so that the MTA will keep going.
    return(SMFIS_CONTINUE);
}

# Gets called after the sender admits where the message is coming from.
# We should have the sender's address set in $ctx private data, so we
# can compare at this point.
sub envrcpt_callback {
    my $ctx = shift;
    my $recipient = shift;
    
    my $private = $ctx->getpriv();

    syslog("info","Entered envrcpt callback with sender $private->{'sender'}") if DEBUGGING;

    # Clean up our recipient.
    # Remove any newlines or whitespace.
    chomp($recipient);
    $recipient =~ s/\s//g;
    
    # Make sure it is 100% lowercased.
    $recipient = lc($recipient);
    
    # Remove anything before the opening carat, if anything.
    $recipient =~ s/^.*?</</;

    syslog("info","Recipient is: $recipient") if DEBUGGING;

    # If it wants to send to gknstl.com...
    if($recipient =~ /\@gknstl\.com/){
        # Set a proper reply and reject the message before the body even comes through.
        syslog("warning","Wants to send to gknstl.com.  DIE!");
        $ctx->setreply('550','5.7.1',"Blocked by GKN Milter, reason 3");
        return(SMFIS_REJECT); 
    }
    
    # Compare the sender and recipient.  Reject if they are the same.
    # Remember that we are de-referencing the sender scalar, so 2 $'s are
    # required.
    if($recipient eq $private->{'sender'}){

        syslog("warning","Sender and recipient are the same.  KILL! KILL! KILL!!!");

        # Purge the private data.
        $ctx->setpriv();

        # Set a proper reply and reject the message before the body even comes through.
        $ctx->setreply('550','5.7.1',"Blocked by GKN Milter, reason 1");
        return(SMFIS_REJECT);        
    }
    else{
        syslog("info","Sender and recipient are different. Carry on then.") if DEBUGGING;

        return(SMFIS_CONTINUE);
    }


}

  # This is our main() loop.  The above it what happens as a bunch of subs,
  # but beneath this point we're actually instantiating our daemon.
  BEGIN:
  {
        my $unix_socket = shift(@ARGV);
        die("You must specify the path to where you want the socket for this milter to exist! - eg /var/spool/postfix/gknmilter.sock") unless $unix_socket;

        print "Opening syslog statement.\n" if DEBUGGING;
        # Set up our initial syslogging parameters.
        openlog('gknmilter','ndelay,nwait,pid','mail');
        syslog("info","Attempting to startup.");

        if(-d $unix_socket){ # If they tried to pass us a directory...
            syslog("error","The path specified, $unix_socket, is a directory.  Exiting.");
            die("The sock path, $unix_socket is a directory.  Please correct this or choose a different socket path.")
        }
        # If by chance the socket path exists, we'll try to clean it up
        # and continue anyway.
        if(-e $unix_socket){
            print "The socket path specified already exists.  Attempting to clean up and continue...\n";
            syslog("warning","The socket path specified already exists.  Attempting to clean up and continue.");

            unless( unlink($unix_socket) ){
                my $username = getpwuid($>);
                syslog("error","Failed to remove $unix_socket.  We are running as $username, maybe a permissions problem?  Exiting.");
                die("Failed to remove $unix_socket.  We are running as $username, maybe a permissions problem?");
            }
            else{
                syslog("info","Cleanup of $unix_socket succeeded.  Continuing.");
                print "Succeeded in cleanup.  Proceeding!\n";
            }
        }

        syslog("info","Setting up socket at $unix_socket");
        print "Setting up socket.\n" if DEBUGGING;
        
        # This should create a new socket.
        $milter->setconn("local:$unix_socket");
        
        syslog("info","Socket created, attempting to register callbacks.");
        print "Socket created, attempting to register callbacks.\n" if DEBUGGING;

        print "Attempting to drop permissions to user postfix.\n" if DEBUGGING;

        my $postfix_uid = getpwnam('postfix');
        syslog("error",'Failed to determine the uid for user "postfix".  Exiting.') unless $postfix_uid;
        die("Failed to determine postfix's uid.  Does the user not exist?") unless $postfix_uid;
        my $postfix_gid = getgrnam('postfix');
        syslog("error",'Failed to determine the gid for group "postfix".  Exiting.') unless $postfix_gid;
        die("Failed to determine postfix's gid.  Does the group not exist?") unless $postfix_gid;

        syslog("info","Changing ownership of $unix_socket to postfix:postfix");
        chown($postfix_uid,$postfix_gid,$unix_socket);

        # This should register our new callbacks.
        $milter->register("gknmilter",$milter_callbacks, SMFI_CURR_ACTS);

        syslog("info","Callbacks registered.  Attempting to drop permissions.");
        print "Callbacks registered.  Attempting to drop permissions.\n" if DEBUGGING;

        # Set our effective UID (EUID) to $postfix_uid.
        $> = $postfix_uid;
        syslog("error","Failed to drop permissions to postfix user with uid $postfix_uid") unless ($> == $postfix_uid);
        die("Failed to drop permissions to postfix user with uid $postfix_uid") unless ($> == $postfix_uid);
        print "Successfully dropped permissions to user postfix with uid $postfix_uid.\n" if DEBUGGING;

        # Set our effective GID (EGID) to $postfix_gid.
        # This is not an error.  Apparently to force a single gid, you have to give
        # the gid, then give it again in a space-separated list to force setgroup() to use just one.
        $) = "$postfix_gid $postfix_gid";

        syslog("warning","Failed to drop permissions to postfix group with gid $postfix_gid") unless ( $) eq "$postfix_gid $postfix_gid" );
        warn("Failed to drop permissions to postfix group with gid $postfix_gid.  Our EGID is $).
             This is not fatal, as not all systems support it.  Continuing.") unless ( $) eq "$postfix_gid $postfix_gid");
        print "Successfully dropped permissions to group postfix with gid $postfix_gid.\n"
            if ( DEBUGGING && ( $) eq "$postfix_gid $postfix_gid") );

        print "Entering main loop to daemonize.\n" if DEBUGGING;
        syslog("info","Entering main loop to daemonize.");

        $milter->main();

        # Never reaches here, callbacks are called from Milter.
  }