openpkg-packages/milter-header/milter-header.pl

#!@l_prefix@/bin/perl
##
##  milter-header -- Header Insertion MILTER Program
##  Copyright (c) 2007-2009 Ralf S. Engelschall <rse@engelschall.com>
##

#   requirements
require 5.008;
use warnings;
use strict;
use IO::All;
use IO::File;
use OSSP::cfg;
use Date::Format;
use Data::Dumper;
use Sendmail::PMilter qw(:all);

#   command line handling
my $cfgfile = $ARGV[0] || "@l_prefix@/etc/milter-header/milter-header.cfg";

#   parse configuration file
my $txt < io($cfgfile);
my $cfg = new OSSP::cfg::simple;
$cfg->parse($txt);
my $tree = $cfg->unpack();
undef $cfg;

#   determine milter parameters
my ($socket)       = map { $_->[1]    } grep { ref($_) eq 'ARRAY' and $_->[0] eq 'socket'       } 
                     map { @{$_->[1]} } grep { ref($_) eq 'ARRAY' and $_->[0] eq 'milter'       } @{$tree};
my ($logfile)      = map { $_->[1]    } grep { ref($_) eq 'ARRAY' and $_->[0] eq 'logfile'      } 
                     map { @{$_->[1]} } grep { ref($_) eq 'ARRAY' and $_->[0] eq 'milter'       } @{$tree};
my ($max_backlog)  = map { $_->[1]    } grep { ref($_) eq 'ARRAY' and $_->[0] eq 'max_backlog'  } 
                     map { @{$_->[1]} } grep { ref($_) eq 'ARRAY' and $_->[0] eq 'milter'       } @{$tree};
my ($max_childs)   = map { $_->[1]    } grep { ref($_) eq 'ARRAY' and $_->[0] eq 'max_childs'   } 
                     map { @{$_->[1]} } grep { ref($_) eq 'ARRAY' and $_->[0] eq 'milter'       } @{$tree};
my ($max_requests) = map { $_->[1]    } grep { ref($_) eq 'ARRAY' and $_->[0] eq 'max_requests' } 
                     map { @{$_->[1]} } grep { ref($_) eq 'ARRAY' and $_->[0] eq 'milter'       } @{$tree};

#   determine header actions
my @action = ();
foreach my $action (map { $_->[1] } grep { ref($_) eq 'ARRAY' and $_->[0] eq 'action' } @{$tree}) {
    my @require = map  { my $value = $_->[2]; $value =~ s/^\s+//s; $value =~ s/\s+$//; my $x = { -name => $_->[1], -value => $value }; $x } 
                  grep { ref($_) eq 'ARRAY' and $_->[0] eq 'require' } @{$action};
    my @insert  = map  { my $value = $_->[2]; $value =~ s/^\s+//s; $value =~ s/\s+$//; my $x = { -name => $_->[1], -value => $value }; $x } 
                  grep { ref($_) eq 'ARRAY' and $_->[0] eq 'insert'  } @{$action};
    push(@action, { -require => [ @require ], -insert => [ @insert ] });
}

#   helper function for logging
sub logbook ($;@) {
    my ($fmt, @args) = @_;
    my $log = new IO::File ">>$logfile";
    if (defined $log) {
        $log->printf("%s %05d %s\n", time2str("%Y-%m-%d %H:%M:%S", time()), $$, sprintf($fmt, @args));
        $log->close();
    }
}

#   catch run-time warnings from Sendmail::PMilter
$SIG{__WARN__} = sub {
    my ($err) = @_;
    $err =~ s/\r?\n$//s;
    logbook("MILTER Warning: %s", $err);
};

#   create milter
umask(002);
unlink($socket);
my $milter = new Sendmail::PMilter;
my $dispatcher = Sendmail::PMilter::prefork_dispatcher(
    max_children           => $max_childs,
    max_requests_per_child => $max_requests,
);
$milter->set_dispatcher($dispatcher);
$milter->set_listen($max_backlog);
$milter->setconn("local:$socket");
$milter->register(
    "milter-header", { 
        'connect'  => \&milter_cb_connect,
        'header'   => \&milter_cb_header,
        'eom'      => \&milter_cb_eom,
    }, 
    (SMFI_V2_ACTS|SMFIF_ADDHDRS)
);
logbook("started");
$milter->main();
logbook("terminated");
exit(0);

#   milter hook: connect
sub milter_cb_connect {
    my ($ctx, $hostname, $hostaddr) = @_;
    my $status = { -header => [] };
    $ctx->setpriv($status);
    return SMFIS_CONTINUE;
}

#   milter hook: header
sub milter_cb_header {
    my ($ctx, $name, $value) = @_;
    my $status = $ctx->getpriv();
    push(@{$status->{-header}}, { -name => $name, -value => $value });
    return SMFIS_CONTINUE;
};

#   milter hook: end of message
sub milter_cb_eom ($;@) {
    my ($ctx) = @_;
    my $status = $ctx->getpriv();

    #   loop over all header actions
    foreach my $action (@action) {
        #   check number of fulfilled requirements
        my $fulfilled = 0;
        foreach my $require (@{$action->{-require}}) {
            #logbook("check requirement: header \"%s\" regex \"%s\"", $require->{-name}, $require->{-value});
            foreach my $header (@{$status->{-header}}) {
                #logbook("compare with header \"%s\" value \"%s\"", $header->{-name}, $header->{-value});
                my $regex = $require->{-value};
                if (    uc($header->{-name}) eq uc($require->{-name})
                    and $header->{-value} =~ m/$regex/) {
                    #logbook("requirement fulfilled by header \"%s\" value \"%s\"", $header->{-name}, $header->{-value});
                    $fulfilled++; 
                }
            }
        }
        if ($fulfilled == scalar(@{$action->{-require}})) {
            #   if _all_ requirements are fulfilled
            foreach my $insert (@{$action->{-insert}}) {
                my $value = $insert->{-value};
                $value =~ s/\s*\n+$//s;
                $value =~ s/^\s+//s;
                $value =~ s/\n\s+/\n\t/sg;
                if (grep { $_->{-name} eq $insert->{-name} } @{$status->{-header}}) {
                    #logbook("change existing header \"%s\" value \"%s\"", $insert->{-name}, $insert->{-value});
                    logbook("change existing header \"%s\"", $insert->{-name});
                    $ctx->chgheader($insert->{-name}, 0, $value);
                }
                else {
                    #logbook("add new header \"%s\" value \"%s\"", $insert->{-name}, $insert->{-value});
                    logbook("add new header \"%s\"", $insert->{-name});
                    $ctx->addheader($insert->{-name}, $value);
                }
            }
        }
    }
    return SMFIS_CONTINUE;
}