#!/usr/bin/perl # (not using -w -T for speed's sake) # BDKIM # Copyright (c) 2011, Casey Connor # All rights reserved. # # Redistribution and use in source and binary forms, with or without modification, # are permitted provided that the following conditions are met: # # - Redistributions of source code must retain the above copyright notice, this # list of conditions and the following disclaimer. # - Redistributions in binary form must reproduce the above copyright notice, # this list of conditions and the following disclaimer in the documentation # and/or other materials provided with the distribution. # - Neither the name of Lacinato nor the names of its contributors may be used to # endorse or promote products derived from this software without specific prior # written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY # EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES # OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT # SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED # TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR # BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, # STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE # USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # # Version 1.0 # Casey Connor -- lacinato.com # http://lacinato.com/cm/software/emailrelated/bdkim ######################################################### # See BDKIM.conf for info about important config options! ######################################################### # This requires Mail::DKIM::Verifier and ::Signature (tested with versions 0.33 through 0.38, probably fine with 0.39), and Net::Server::PreFork # This is a perl server that handles requests from the Java-side BdkimClient class # (or any other custom client you care to write) to interface into Mail::DKIM in # order to provide DKIM analysis results. # Protocol: # Client connects, either sends entire message or uses "early-exit" mode. # # If client sends entire message: # Server responds with: # First line: "TE\n" or "TS\n" for error or successful transmission. # If TE, next line is a one-line explanation of the transmission error. # If TS, what follows is the result of the DK/DKIM checking: # If DE, next line is a one-line explanation of the DK/DKIM checking error # If DS, what follows is the structured response of the analysis: # first line: integer >= 0 representing number of sets of signature results, # each of which has form: # line 1: domain string # line 2: header-list string (:-separated list from h= tag, with whitespace removed, etc) # line 3: result string ("detailed" version from Mail::DKIM) # (The domain string or header string may be an empty line, but the result string should always # be present in some form). # # If, instead, client connects and first sends a line consisting of "EE", server enters "early-exit" mode. # Following "EE\n", client sends just the header lines as well as one extra newline # after the last header (as with a standard email message.) # Server then responds with: # HC: meaning no results are yet available, client should send ("[C]ontinue") the rest of the message. # Results per non-early-exit mode, as described above. # TS: meaning early-exit results are available, client should send nothing else. If TS, server follows with # same results as after "TS", as described above. # TE: meaning there was a header transmission error. Next line is a one-line explanation of the error. # if server process is given HUP or killed, it will immediately kill the children # while they operate. (See sub close_children in the Net::Server code.) # Thus you should stop processing in your client before stopping or restarting # BDKIM, or accept the possible consequence that doing so will result in # no DKIM results for whatever messages were in process at the time, or network errors/timeouts/etc. # NOTE: a Mail::DKIM limitation means that the header list that is returned in the # case of DomainKey signatures which lack the optional h= tag will be empty! package BDKIM; use strict; use warnings; use base qw(Net::Server::PreFork); use Mail::DKIM::Verifier; use Mail::DKIM::Signature; # the custom options # see config files for documentation my $timeout = undef; my $message_size_limit = undef; my $should_clean_lines = undef; BDKIM->run(conf_file => 'BDKIM.conf'); # These are overridden subroutines from the net package: sub process_request { my $self = shift; my $dkim_v = Mail::DKIM::Verifier->new(); eval { local $SIG{'ALRM'} = sub { die "TE:Client timed out!\n" }; my $previous_alarm = alarm($timeout); my $count = 0; my $body_exists = 1; # first look for "EE", which means we're in "early exit" header scan mode my $firstline = <STDIN>; if ($firstline) { if ($should_clean_lines) { chomp $firstline; $firstline =~ s/\015$//; } if ($firstline =~ m/^[\000\xFF]/) { die "TE:no input"; } } else { die "TE:no input"; } if ($firstline eq "EE" || $firstline eq "EE\015\012") { # Early-Exit mode: client sends headers only and then waits for our response while (<STDIN>) { if ($should_clean_lines) { chomp; s/\015$//; } if ($_ eq "" || $_ eq "\015\012") { $dkim_v->PRINT("\015\012"); # must include the blank line for Mail::DKIM to evaluate headers # Headers are done, see if there are preliminary results my $result = check_header_only_results($self, $dkim_v); if ($result) { # results are in, so return the results print "TS\n$result"; return; #simply exits the eval block } else { # no results, so we need the rest of the message print "HC\n"; last; } } elsif (/^[\000\xFF]/) { $body_exists = 0; last; } else { if ($should_clean_lines) { $dkim_v->PRINT("$_\015\012"); } else { $dkim_v->PRINT("$_"); } } # to be strict, these length()'s should probably add 2 for the \015\012 conditionally chomped/added $count += length(); if ($count > $message_size_limit) { die "TE:maxsize"; } alarm($timeout); } } else { # Non-early-exit mode: client sends entire message and then waits for server response # first add the first line in, then fall through to read rest of message if ($should_clean_lines) { $dkim_v->PRINT("$firstline\015\012"); } else { $dkim_v->PRINT("$firstline"); } # to be strict, these length()'s should probably add 2 for the \015\012 conditionally chomped/added $count += length($firstline); if ($count > $message_size_limit) { die "TE:maxsize"; } alarm($timeout); } # read entire message (non-early-exit mode), or rest of message (early-exit mode but need rest of message) if ($body_exists) { while (<STDIN>) { if ($should_clean_lines) { chomp; s/\015$//; } # for some reason there is a stream of nulls at the end of the transmission # this also breaks out on \xFF so it can be used from telnet by sending eof # and then hitting enter if (/^[\000\xFF]/) { last; } else { if ($should_clean_lines) { $dkim_v->PRINT("$_\015\012"); } else { $dkim_v->PRINT("$_"); } } # to be strict, these length()'s should probably add 2 for the \015\012 conditionally chomped/added $count += length(); if ($count > $message_size_limit) { die "TE:maxsize"; } alarm($timeout); } } # either non-early-exit or early-exit-but-all-message-needed and we're done reading it all in, so give results: if ($count == 0) { # empty or null input from client print "TE\nServer received no input."; alarm($previous_alarm); } else { alarm($previous_alarm); # transmission finished, compute results my $result = compute_DKIM($self, $dkim_v, 1); print "TS\n$result"; } }; if ($@) { if ($@ =~ /te:client timed out/i) { print "TE\nClient timed out."; $self->log(1, localtime() . ": WARNING: client timed out!"); } elsif ($@ =~ /te:maxsize/i) { # message too big print "TE\nServer received excessively-long message. Max size in bytes: " . $message_size_limit; } elsif ($@ =~ /te:no input/i) { # no server input (detected before loop) print "TE\nServer received no input."; } else { $self->log(1, localtime() . ": WARNING: uncaught exception (indicates bug): [" . $@ . "]"); } } return; } sub check_header_only_results { my $self = shift; my $result; eval { my $dkim_v = shift; if (my $rough_result = $dkim_v->result()) { if ($rough_result eq "none" || $rough_result eq "invalid") { $result = compute_DKIM($self, $dkim_v, 0); return; # just exits the eval block } } $result = ""; }; if ($@) { my $errorstr = "Exception while processing header-only info from Mail::DKIM: [" . $@ . "]"; $self->log(1, localtime() . ": " . $errorstr); } else { return $result; } } sub compute_DKIM { my $self = shift; my $result = ""; eval { my $dkim_v = shift; my $should_close = shift; if ($should_close) { $dkim_v->CLOSE; } my @sigs = $dkim_v->signatures; $result .= scalar @sigs . "\n"; my $cur_str; foreach (@sigs) { $cur_str = $_->domain; $result .= ($cur_str?"$cur_str\n":"\n"); $cur_str = $_->headerlist; #Mail::DKIM (as of version 0.38) bug -- sometimes returns multi-line header results for badly-formed sigs, so strip \n and \r: $cur_str =~ s/[\r\n]+//g; $result .= ($cur_str?"$cur_str\n":"\n"); $cur_str = $_->result_detail; $result .= ($cur_str?"$cur_str\n":"\n"); } $result = "DS\n" . $result; }; if ($@) { my $errorstr = "Exception while processing results from Mail::DKIM: [" . $@ . "]"; $self->log(1, localtime() . ": " . $errorstr); return("DE\n" . $errorstr); } else { return $result; } } # tell system to read in our custom options sub options { my $self = shift; my $prop = $self->{'server'}; my $template = shift; $self->SUPER::options($template); $prop->{'timeout'} ||= undef; $template->{'timeout'} = \ $prop->{'timeout'}; $prop->{'message_size_limit'} ||= undef; $template->{'message_size_limit'} = \ $prop->{'message_size_limit'}; $prop->{'should_clean_lines'} ||= undef; $template->{'should_clean_lines'} = \ $prop->{'should_clean_lines'}; # for multi-value options: # $prop->{'an_arrayref_item') ||= []; # $template->{'an_arrayref_item'} = $prop->{'an_arrayref_item'}; } # extract and verify our custom options # new additions must be reflected in previous sub as well sub post_configure_hook() { my $self = shift; my $prop = $self->{'server'}; $timeout = $prop->{'timeout'}; # start with non-0 digit, followed by 0-5 more digits, only if (! ($timeout =~ /^[123456789]\d{0,5}$/)) { # pretty sure this is the way to fail die ('value specified in config for timeout was malformed: [' . $timeout . "]"); } $message_size_limit = $prop->{'message_size_limit'}; # start with non-0 digit, followed by 0-8 more digits, only if (! ($message_size_limit =~ /^[123456789]\d{0,8}$/)) { # pretty sure this is the way to fail die ('value specified in config for message_size_limit was malformed: [' . $message_size_limit . "]"); } $should_clean_lines = $prop->{'should_clean_lines'}; } 1;