Code cleanup, option parsing and "--help"

1 files changed, 208 insertions, 79 deletions

diff --git a/dmarc_milter.pl b/dmarc_milter.pl
index bdb6e0b..d408329 100755
--- a/dmarc_milter.pl
+++ b/dmarc_milter.pl
@@ -4,113 +4,242 @@ use strict;
 use warnings;
 use feature 'say';
 
+no warnings 'experimental::signatures';
+use feature 'signatures';
+
 use lib '.';
 
+use Getopt::Long;
+use Pod::Usage;
 use Sendmail::Milter;
 use Spline::DMARC qw(check_addresses);
-use Spline::Log qw(set_verbose debug info);
 use Spline::Data;
+use Spline::Log qw(set_verbose set_stderr debug info);
 
-use Data::Dumper;
-
-my %milter_callbacks = (
-    'envfrom' => \&from_callback,
-    'envrcpt' => \&rcpt_callback,
-    'header' => \&header_callback,
-    'eoh' => \&eom_callback,
-    'abort' => \&abort_callback,
-    'close' => \&close_callback,
-);
 
-sub from_callback($$@) {
-    my $ctx = shift;
-    my $from = shift;
+# This is the mainloop. This method will not exit before shutdown of
+# the milter interface.
+sub main($listen, $mailman, $message) {
 
-    my $data = Spline::Data->new($ctx);
-    $data->set('counter', 0);
+    Sendmail::Milter::setconn($listen);
 
-    debug "MAIL FROM: $from";
-    return SMFIS_CONTINUE;
+    # Setup the callbacks
+    Sendmail::Milter::register('dmarc_milter', {
+        'envfrom' => sub($ctx, $from, @) {
+            # We only need this callback to initialize the private
+            # data and the logging context.
+            my $data = Spline::Data->new($ctx);
+            $data->set('counter', 0);
+
+            debug "MAIL FROM: $from";
+            return SMFIS_CONTINUE;
+        },
+
+        'envrcpt' => sub($ctx, $rcpt_to, @) {
+            my $data = Spline::Data->load($ctx);
+            debug "RCPT TO: $rcpt_to";
+
+            my $next_hop = $ctx->getsymval('{rcpt_host}');
+            if ($next_hop eq $mailman) {
+                info "Mailinglist address: $rcpt_to";
+                $data->set('counter', 1);
+            }
+
+            return SMFIS_CONTINUE;
+        },
+
+        'header' => sub($ctx, $name, $value) {
+            my $data = Spline::Data->load($ctx);
+
+            # If there was no Mailinglist address, we can simply
+            # accept this mail and skip all following callbacks
+            return SMFIS_ACCEPT if $data->get('counter') == 0;
+
+            debug "HEADER '$name': $value";
+            if (lc($name) eq 'from') {
+                my $reject = check_addresses($value);
+                if ($reject) {
+                    info 'Rejecting mail!';
+                    $ctx->setreply('550', '5.7.2', $message);
+
+                    # REJECT here. No more callbacks, are called for
+                    # this message.
+                    return SMFIS_REJECT;
+                }
+            }
+
+            return SMFIS_CONTINUE;
+        },
+
+        'eoh' => sub($ctx) {
+            my $data = Spline::Data->load($ctx);
+            debug 'END OF HEADER';
+
+            # If we did not reject this message during the headers, we
+            # can now accept it and do not call anymore callbacks for
+            # this message.
+            return SMFIS_ACCEPT;
+        },
+
+        'close' => sub($ctx) {
+            Spline::Data->load($ctx);
+
+            # Free the connection-private memory.
+            $ctx->setpriv(undef);
+
+            debug 'CLOSE';
+            return SMFIS_CONTINUE;
+        },
+    });
+
+    # Start the mainloop:
+    # No interpreter limit, but recycle after 100 requests
+    Sendmail::Milter::main(0, 100);
 }
 
-sub rcpt_callback($$@) {
-    my $ctx = shift;
-    my $rcpt_to = shift;
-
-    my $data = Spline::Data->load($ctx);
-    debug "RCPT TO: $rcpt_to";
+my $help;
+my $verbose;
+my $stderr;
+my $message = 'Your provider does not permit sending to ' .
+              'mailing lists (DMARC policy)';
+my $mailman = '[lists.spline.inf.fu-berlin.de]';
+
+# work on options
+GetOptions(
+    "verbose|v"   => \$verbose,
+    "help|h|?"    => \$help,
+    "stderr|s"    => \$stderr,
+    "message|r=s" => \$message,
+    "mailman|m=s" => \$mailman,
+);
 
-    my $next_hop = $ctx->getsymval('{rcpt_host}');
-    if ($next_hop eq '[lists.spline.inf.fu-berlin.de]') {
-        info "Mailinglist address: $rcpt_to";
-        $data->set('counter', 1);
+# show help
+if ($help) {
+    if ($verbose) {
+        pod2usage(-verbose => 2,
+                  -noperldoc => 1);
+    }
+    else {
+        pod2usage();
     }
 
-    return SMFIS_CONTINUE;
+    exit;
 }
 
-sub header_callback($$$) {
-    my $ctx = shift;
-    my ($field, $value) = @_;
- 
-    my $data = Spline::Data->load($ctx);
-    debug "HEADER '$field': $value";
-
-    if (lc($field) eq 'from') {
-        return SMFIS_CONTINUE if $data->get('counter') == 0;
-
-        my $reject = check_addresses($value);
-        if ($reject) {
-            info 'Rejecting mail';
-            $ctx->setreply('550', '5.7.2', 'Your provider does not permit sending to mailing lists (DMARC policy)');
-            return SMFIS_REJECT;
-        }
-    }
-
-    # We cannot SMFIS_ACCEPT here, because there could
-    # be multiple From headers.
-    return SMFIS_CONTINUE; 
+# check argument count
+if ($#ARGV < 0) {
+    say STDERR 'SOCKET, PORT or CONNECTION_INFO required!';
+    pod2usage();
+    exit;
 }
 
-sub eoh_callback($) {
-    my $ctx = shift;
+# Setup logging
+if ($verbose) {
+    set_verbose(1);
+}
 
-    my $data = Spline::Data->load($ctx);
-    $data->set('counter', 0);
+if ($stderr) {
+    set_stderr(1);
+}
 
-    debug 'END OF HEADER';
-    return SMFIS_ACCEPT;
+# Build the connection info if only a PORT or Path is given
+my $arg = shift;
+my $listen;
+if ($arg =~ /^\d+$/ ) {
+    $listen = "inet:$arg\@localhost";
+}
+elsif ($arg =~ /^\//) {
+    $listen = "local:$arg";
+}
+else {
+    $listen = "$arg";
 }
 
-sub abort_callback($) {
-    my $ctx = shift;
+# Start the mainloop
+info "Listening on $listen..." if $stderr;
+main($listen, $mailman, $message);
 
-    my $data = Spline::Data->load($ctx);
-    $data->set('counter', 0);
+__END__
 
-    debug 'ABORT';
-    return SMFIS_CONTINUE;
-}
+=head1 NAME
 
-sub close_callback($) {
-    my $ctx = shift;
-    
-    Spline::Data->load($ctx);
-    $ctx->setpriv(undef);
+dmarc_milter.pl - Milter to check if a mailinglist mail would be rejected because of DMARC.
 
-    debug 'CLOSE';
-    return SMFIS_CONTINUE;
-}
+=head1 SYNOPSIS
 
-sub main($) {
-    my $listen = shift;
+dmarc_milter [options] ( SOCKET | PORT | CONNECTION_INFO )
 
-    Sendmail::Milter::setconn($listen);
-    Sendmail::Milter::register("dmarc_lists_filter",
-        \%milter_callbacks, SMFI_CURR_ACTS);
-    Sendmail::Milter::main();
-}
+ Options:
+   --help|-h|-?       show usage info and exit
+   --verbose|-v       enable more output (even for --help)
+
+   --stderr|-s        log to stderr
+   --mailman|-m HOST  specify an alternativ mailman host
+   --message|-r MSG   specify an alternativ reject message
+
+You have to specify where the milter should listen for connections
+from your MTA. You can specify a single TCP port (on localhost) or an
+absolute path to a socket file. If you have special requirements you
+could specify a full connection info string. The format is described
+in the Milter documentation. Some examples are
+C<local:/var/run/f1.sock>, C<inet6:999@localhost>,
+C<inet:3333@localhost>.
+
+(Note: The format of the connection string in the postfix config is
+different.)
+
+=head1 DESCRIPTION
+
+B<dmarc_milter.pl> is a Perl script that listen on a socket or tcp
+port and retrieves requests from a MTA via the milter protocol
+(originaly by sendmail).
+
+The script will scan all emails and check if there are destination
+addresses "Envelope To" of mailinglists. If there is at least one, all
+the milter will check if any address in the "From" header has
+specified a DMARC reject policy.
+
+Such mail would be bounced by all MTAs that respect DMARC, after
+mailman resends the message.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<--verbose>, B<-v>
+
+More verbose output. It will log DEBUG messages, too.
+
+=item B<--help>, B<-h>, B<-?>
+
+Print brief help message and exit.
+
+=item B<--stderr>, B<-s>
+
+Log to stderr instead of syslog.
+
+=item B<--mailman>, B<-m> C<HOST>
+
+Set the mailman host to the specified value. This is the value of the
+I<{rtpc_host}> macro for the mailinglist mails. It should be in the
+same format as set by the MTA. The default value is:
+C<[lists.spline.inf.fu-berlin.de]>.
+
+=item B<--message>, B<-r> C<MESSAGE>
+
+Set the message, if rejecting a mail. The default messages is: "Your
+provider does not permit sending to mailing lists (DMARC policy)."
+
+=back
+
+=head1 AUTHORS
+
+Alexander Sulfrian <alex@spline.inf.fu-berlin.de>
+
+=head1 SEE ALSO
+
+Sendmail::Milter(3pm), postconf(7)
 
-main('inet:12345@localhost');
+=cut
 
 # vim: set et tabstop=4 tw=70: