Courier::Filter - Purely Perl-based mail filter framework for the Courier MTA

    use Courier::Filter;
    use Courier::Filter::Logger::Moo;
    use Courier::Filter::Module::Foo;
    use Courier::Filter::Module::Bar;

    my $filter = Courier::Filter->new(
        mandatory   => 1,
        logger      => Courier::Filter::Logger::Moo->new( ... ),
        modules     => [
            Courier::Filter::Module::Foo->new( ... ),
            Courier::Filter::Module::Bar->new( ... )
        ],
        testing     => 0,
        debugging   => 0
    );

    my $exit_code = $filter->run() || 0;

    exit($exit_code);

#
# Courier::Filter
# A purely Perl-based filter framework for the Courier MTA.
#
# (C) 2003-2008 Julian Mehnle <julian@mehnle.net>
# $Id: Filter.pm 210 2008-03-21 19:30:31Z julian $
#
###############################################################################

package Courier::Filter;

use version; our $VERSION = qv('0.200');

use warnings;
use strict;
#use threads;
#BEGIN { require threads if ... }

use Error ':try';

use IO::Handle;
use IO::Socket::UNIX;
use IO::Select;

use Courier::Config;
use Courier::Message;
use Courier::Error;

use constant TRUE   => (0 == 0);
use constant FALSE  => not TRUE;

# Implementation:
###############################################################################

sub new {
    my ($class, %options) = @_;
    
    $0 =~ m{([^/]+)$};
    my $name        = $options{name} || $1;
    my $mandatory   = defined($options{mandatory}) ? $options{mandatory} : TRUE;
    my $threads     = $options{threads};
    my $logger      = $options{logger};
    my $modules     = [ @{$options{modules}} ] || [];
    my $trusting    = $options{trusting};
    my $testing     = $options{testing};
    my $debugging   = $options{debugging};
    
    my $socket_dir =
        Courier::Config->runtime_dir . '/' .
        ( $mandatory ? 'allfilters' : 'filters' );
    my $socket_dir_unused =
        Courier::Config->runtime_dir . '/' .
        ( !$mandatory ? 'allfilters' : 'filters' );
    
    my $socket_prename          = "$socket_dir/.$name";
    my $socket_name             = "$socket_dir/$name";
    my $socket_prename_unused   = "$socket_dir_unused/.$name";
    my $socket_name_unused      = "$socket_dir_unused/$name";
    
    if (-e $socket_name) {
        -S $socket_name
            or throw Courier::Error("$socket_name already exists but is not a socket");
        
        # Try to connect to socket to see if it is alive or
        # if it is left over from a crashed Courier::Filter:
        my $test_socket = IO::Socket::UNIX->new( Peer => $socket_name );
        
        not defined($test_socket)
            or throw Courier::Error("Live socket $socket_name found -- is Courier::Filter already running?");
        
        # Socket exists but is dead. Remove it:
        unlink($socket_name);
    }
    
    unlink($socket_prename);
    unlink($socket_prename_unused);
    unlink($socket_name_unused);
    
    my $socket = IO::Socket::UNIX->new(
        Local   => $socket_prename,
        Listen  => SOMAXCONN
    )
        or  throw Courier::Error("Unable to create socket $socket_prename");
    
    rename($socket_prename, $socket_name)
        or  unlink($socket_prename),
            throw Courier::Error("Unable to rename socket $socket_prename to $socket_name");
    
    chmod(0660, $socket_name)
        or  throw Courier::Error("Unable to chmod socket $socket_name");
    
    IO::Handle->new_from_fd(3, '>')->close();
    
    my $filter = {
        name        => $name,
        mandatory   => $mandatory,
        threads     => $threads,
        logger      => $logger,
        modules     => $modules,
        trusting    => $trusting,
        testing     => $testing,
        debugging   => $debugging,
        socket      => $socket,
        socket_name => $socket_name,
        terminate   => FALSE
    };
    
    return bless($filter, $class);
}

sub destroy {
    my ($filter) = @_;
    
    return if not $filter->{terminate};
    
    $filter->{'socket'}->close();
    unlink($filter->{socket_name});
    
    # Dissolve worker thread pool:
#    foreach my $thread (threads->list) {
#        $thread->join()
#            if $thread->tid and $thread != threads->self;
#    }
    
    return;
}

sub run {
    my ($filter) = @_;
    my $class = ref($filter);
    
    my $socket = $filter->{'socket'};
    my $select = IO::Select->new(\*STDIN, $socket);
    
    while (not $filter->{terminate}) {
        
        # Wait for incoming connection requests
        # or EOF from STDIN:
        ########################################
        
        my @ready_handles = $select->can_read();
        
        foreach my $handle (@ready_handles) {
            if ($handle == $socket) {
                # Incoming connection request.
                $filter->handle_connection($socket);
#                threads->new(\&handle_connection, $filter, $socket)->detach();
            }
            elsif ($handle == \*STDIN and STDIN->eof()) {
                # STDIN got closed.
                $filter->{terminate} = TRUE;
            }
            else {
                # Received data from unknown handle or from STDIN.
                # This shouldn't happen.
                throw Courier::Error("Received data from unknown handle or from STDIN");
            }
        }
    }
    
    return;
}

sub handle_connection {
    my ($filter, $socket) = @_;
    my $class = ref($filter);
    
    my $connection = $socket->accept();
    
    my $message_file_name;
    my @control_file_names;
    
    while (my $file_name = <$connection>) {
        chomp($file_name);
        last unless $file_name;
        
        # Normalize file name:
        $file_name =
            Courier::Config->runtime_dir . '/tmp/' . $file_name
            if $file_name !~ m(^/);
        
        if (not defined($message_file_name)) {
            $message_file_name = $file_name;
        }
        else {
            push(@control_file_names, $file_name);
        }
    }
    
    return
        if not defined($message_file_name);
    
    my $message = Courier::Message->new(
        file_name           => $message_file_name,
        control_file_names  => \@control_file_names,
        filter              => $filter
    );
    
    my ($result, $code);
    
    # BEGIN XXX
    #STDERR->print(
    #    "DEBUG: authenticated_user = '" .
    #    ($message->authenticated_user || '(undef)') .
    #    "'\n"
    #);
    # END XXX
    
    ($result, $code) = $filter->consult_modules($filter->modules, $message)
        if $filter->testing
        or not ($filter->trusting and $message->trusted);
    
    ($result, $code) = (undef, undef)
        if $filter->testing
        or ($filter->trusting and $message->trusted);
    
    if ($result) {
        $code ||= 550;
    }
    else {
        $result = 'Ok';
        $code ||= 200;
    }
    
    my @lines = split(/\n/, $result);
    my $last_line = pop(@lines);
    $connection->print("$code-$_\n") foreach @lines;
    $connection->print("$code $last_line\n");
    
    $connection->close();
    
    return ($result, $code);
}

sub consult_modules {
    my ($filter, $modules, $message) = @_;
    
    ref($modules) eq 'ARRAY'
        or throw Courier::Error('Invalid modules group structure, array-ref expected');

    foreach my $module (@$modules) {
        my ($result, @code);
        
        if (UNIVERSAL::isa($module, 'Courier::Filter::Module')) {
            # Single module, make it consider the message:
            
            next if $module->trusting and $message->trusted;
                # ...except when the module trusts the message.
            
            my $logger = $module->logger || $filter->logger;

            ($result, @code) = eval { $module->consider($message) };
            if ($@) {
                $logger->log_error(ref($module) . ': ' . $@) if $logger;
                ($result, @code) = ('Mail filters temporarily unavailable.', 432);
            }
            
            # Log rejection:
            $logger->log_rejected_message($message, $result)
                if $result and $logger;

            # Ignore result if module is in testing mode:
            next if $module->testing;
        }
        else {
            # Something else, try to interpret it as a modules group:
            ($result, @code) = $filter->consult_modules($module, $message);
        }
        
        return $result ? ($result, @code) : undef
            if defined($result);
    }

    return undef;
}

sub name {
    my ($filter) = @_;
    # Read-only!
    return $filter->{name};
}

sub mandatory {
    my ($filter) = @_;
    # Read-only!
    return $filter->{mandatory};
}

sub threads {
    my ($filter) = @_;
    # Read-only!
    return $filter->{threads};
}

sub logger {
    my ($filter, @logger) = @_;
    $filter->{logger} = $logger[0]
        if @logger;
    return $filter->{logger};
}

sub modules {
    my ($filter, @modules) = @_;
    $filter->{modules} = $modules[0]
        if @modules;
    return $filter->{modules};
}

sub trusting {
    my ($filter) = @_;
    # Read-only!
    return $filter->{trusting};
}

sub testing {
    my ($filter) = @_;
    # Read-only!
    return $filter->{testing};
}

sub debugging {
    my ($filter, @debugging) = @_;
    $filter->{debugging} = $debugging[0]
        if @debugging;
    return $filter->{debugging};
}

BEGIN {
    no warnings 'once';
    *DESTROY = \&destroy;
}

TRUE;