"Fossies" - the Fresh Open Source Software Archive

Member "amavisd-new-2.11.1/amavisd-signer" (27 Jan 2014, 37729 Bytes) of package /linux/misc/amavisd-new-2.11.1.tar.bz2:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 #!/usr/bin/perl -T
    2 
    3 #------------------------------------------------------------------------------
    4 # This is amavisd-signer, a DKIM signing service daemon for amavisd.
    5 # It uses an AM.PDP protocol lookalike to receive a request from amavisd
    6 # and provides two services: choosing a signing key, and signing a
    7 # message digest with a chosen DKIM private key.
    8 #
    9 # Author: Mark Martinec <Mark.Martinec@ijs.si>
   10 #
   11 # Copyright (c) 2010-2014, Mark Martinec
   12 # All rights reserved.
   13 #
   14 # Redistribution and use in source and binary forms, with or without
   15 # modification, are permitted provided that the following conditions
   16 # are met:
   17 # 1. Redistributions of source code must retain the above copyright notice,
   18 #    this list of conditions and the following disclaimer.
   19 # 2. Redistributions in binary form must reproduce the above copyright notice,
   20 #    this list of conditions and the following disclaimer in the documentation
   21 #    and/or other materials provided with the distribution.
   22 #
   23 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
   24 # AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
   25 # IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
   26 # ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
   27 # BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
   28 # CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
   29 # SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
   30 # INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
   31 # CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
   32 # ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33 # POSSIBILITY OF SUCH DAMAGE.
   34 #
   35 # The views and conclusions contained in the software and documentation are
   36 # those of the authors and should not be interpreted as representing official
   37 # policies, either expressed or implied, of the Jozef Stefan Institute.
   38 
   39 # (the above license is the 2-clause BSD license, also known as
   40 #  a "Simplified BSD License", and pertains to this program only)
   41 #
   42 # Patches and problem reports are welcome.
   43 # The latest version of this program is available at:
   44 #   http://www.ijs.si/software/amavisd/
   45 #------------------------------------------------------------------------------
   46 
   47 # Using a separate signing service (which may run under a dedicated UID or
   48 # GID or as root, having exclusive access to private keys) releaves amavisd
   49 # process from needing to have access to private keys. Separating roles can
   50 # provide improved protection for DKIM private keys, and/or can provide more
   51 # flexibility in choosing a signing key.
   52 #
   53 # Usage:
   54 #   amavisd-signer &
   55 
   56 package AmavisSigner;
   57 
   58 use strict;
   59 use re 'taint';
   60 use warnings FATAL => 'utf8';
   61 no warnings 'uninitialized';
   62 
   63 use Sys::Syslog;  # used by Net::Server for logging
   64 use MIME::Base64;
   65 use Mail::DKIM;
   66 use Mail::DKIM::PrivateKey;
   67 
   68 use Net::Server 0.91;
   69 use Net::Server::Multiplex;
   70 use vars qw(@ISA);
   71 @ISA = qw(Net::Server::Multiplex);
   72 
   73 use vars qw(
   74   $VERSION $log_level
   75   %dkim_signing_keys_by_domain
   76   @dkim_signing_keys_list @dkim_signing_keys_storage
   77   @dkim_signature_options_bysender_maps
   78   $daemon_chroot_dir $daemon_user $daemon_group $pid_file $daemonize
   79   $inet_socket_bind @listen_sockets $listen_queue_size
   80   $syslog_ident $syslog_facility
   81 );
   82 
   83 $VERSION = 1.001;  # 20100730
   84 
   85 #
   86 # Please adjust the following settings as necessary:
   87 #
   88 
   89 $daemon_user  = 'vscan';
   90 $daemon_group = 'vscan';
   91 # $daemon_chroot_dir = '/var/amavis';   # chroot directory or undef
   92 
   93 # $daemonize = 1;
   94 
   95 $log_level = 2;  # 0..5
   96 $syslog_facility = 'mail';
   97 $syslog_ident = 'amavisd-signer';
   98 
   99 # the $inet_socket_bind and @listen_sockets should correspond to a
  100 # setting $dkim_signing_service in amavisd.conf :
  101 $inet_socket_bind = '127.0.0.1';
  102 @listen_sockets = ( 20203 );
  103 $listen_queue_size = undef;  # uses a default
  104 
  105 # Load all available private keys and supply their public key RR constraints.
  106 # Arguments are a domain, a selector, a key (a file name of a private key in
  107 # PEM format), followed by optional attributes/constraints (tags, represented
  108 # here as Perl hash key/value pairs) which are allowed by RFC 4871 in a public
  109 # key resource record (v, g, h, k, n, s, t), of which only g, h, k, s and t
  110 # are considered to be constraints limiting the choice of a signing key.
  111 #
  112 #         signing domain   selector     private key              options
  113 #          -------------   --------     ----------------------   ----------
  114 # dkim_key('example.org', 'abc',       '/var/db/dkim/a.key.pem');
  115 # dkim_key('example.org', 'yyy',       '/var/db/dkim/b.key.pem', t=>'s');
  116 # dkim_key('example.org', 'zzz',       '/var/db/dkim/b.key.pem', h=>'sha256');
  117 # dkim_key('example.com', 'sel-2008',  '/var/db/dkim/sel-example-com.key.pem',
  118 #          t=>'s:y', g=>'*', k=>'rsa', h=>'sha256:sha1', s=>'email',
  119 #          n=>'testing; 1, 2');
  120 # dkim_key('guest.example.com', 'g',    '/var/db/dkim/g-guest-ex-com.key.pem');
  121 # dkim_key('mail.example.com', 'notif', '/var/db/dkim/notif-mail.key.pem');
  122 
  123 # @dkim_signature_options_bysender_maps maps author/sender addresses or
  124 # domains to signature tags/requirements; possible signature tags according
  125 # to RFC 4871 are: (v), a, (b), (bh), c, d, (h), i, l, q, s, (t), x, z;
  126 # of which the following are determined implicitly: v, b, bh, h, t
  127 # (tag h is controlled by %signed_header_fields);  currently ignored tags
  128 # are l and z;  instead of an absolute expiration time (tag x) one may use
  129 # a pseudo tag 'ttl' to specify a relative expiration time in seconds, which
  130 # is converted to an absolute expiration time prior to signing: x = t + ttl;
  131 # a built-in default is provided for each tag if no better match is found
  132 #
  133 # @dkim_signature_options_bysender_maps = ( {
  134 #   'postmaster@mail.example.com' => { a => 'rsa-sha1', ttl =>  7*24*3600 },
  135 #   'spam-reporter@example.com'   => { a => 'rsa-sha1', ttl =>  7*24*3600 },
  136 #   'mail.example.com'            => { a => 'rsa-sha1', ttl => 10*24*3600 },
  137 #   # explicit 'd' forces a third-party signature on foreign (hosted) domains
  138 #   'guest.example'               => { d => 'guest.example.com' },
  139 #   '.example.com'                => { d => 'example.com' },
  140 #   # catchall defaults
  141 #   '.' => { a => 'rsa-sha256', c => 'relaxed/simple', ttl => 30*24*3600 },
  142 #   # 'd' defaults to a domain of an author/sender address,
  143 #   # 's' defaults to whatever selector is offered by a matching key
  144 # } );
  145 
  146 
  147 #
  148 # No further user-configurable settings below (but feel free
  149 # to customize code in choose_key_request() or replace it altogether.
  150 #
  151 
  152 sub ll($) {
  153   my($level) = @_;
  154   $level <= $log_level;
  155 }
  156 
  157 my($server);  # a Net::Server object
  158 sub do_log($$;@) {
  159   my($level, $errmsg, @args) = @_;
  160   $errmsg = sprintf($errmsg,@args)  if @args;
  161   if ($level <= $log_level) {
  162     my($prio);  # Net::Server logging priority
  163     # 0=err, 1=warning, 2=notice, 3=info, 4=debug
  164     if    ($level >=  3) { $prio = 4 }
  165     elsif ($level >=  0) { $prio = 2 }
  166     elsif ($level >= -1) { $prio = 1 }
  167     else                 { $prio = 0 }
  168     $server->log($prio, sanitize_str($errmsg));
  169     # Net::Server directs STDERR to the log_file
  170     # print STDERR sanitize_str($errmsg)."\n";
  171   }
  172 }
  173 
  174 sub sanitize_str {
  175   my($str, $keep_eol) = @_;
  176   my(%map) = ("\r" => '\\r', "\n" => '\\n', "\f" => '\\f', "\t" => '\\t',
  177               "\b" => '\\b', "\e" => '\\e', "\\" => '\\\\');
  178   if ($keep_eol) {
  179     $str =~ s/([^\012\040-\133\135-\176])/  # and \240-\376 ?
  180               exists($map{$1}) ? $map{$1} :
  181                      sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/eg;
  182   } else {
  183     $str =~ s/([^\040-\133\135-\176])/      # and \240-\376 ?
  184               exists($map{$1}) ? $map{$1} :
  185                      sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/eg;
  186   }
  187   $str;
  188 }
  189 
  190 sub split_address($) {
  191   my($mailbox) = @_;  local($1,$2);
  192   $mailbox =~ /^ (.*?) ( \@ (?:  \[  (?: \\. | [^\]\\] ){0,999} (?: \] | \z)
  193                               |  [^\[\@] )*
  194                        ) \z/xs ? ($1, $2) : ($mailbox, '');
  195 }
  196 
  197 # THE dkim_key IS A DIRECT COPY OF THE SAME ROUTINE FROM amavisd
  198 #
  199 # Store a private DKIM signing key for a given domain and selector.
  200 # The argument $key can be a Mail::DKIM::PrivateKey object or a file
  201 # name containing a key in a PEM format (e.g. as generated by openssl).
  202 # For compatibility with dkim_milter the signing domain can include a '*'
  203 # as a wildcard - this is not recommended as this way amavisd could produce
  204 # signatures which have no corresponding public key published in DNS.
  205 # The proper way is to have one dkim_key entry for each published DNS RR.
  206 # Optional arguments can provide additional information about the resource
  207 # record (RR) of a public key, i.e. its options according to RFC 4871.
  208 # The subroutine is typically called from a configuration file, once for
  209 # each signing key available.
  210 #
  211 sub dkim_key($$$;@) {
  212   my($domain,$selector,$key) = @_;  shift; shift; shift;
  213   @_%2 == 0 or die "dkim_key: a list of key/value pairs expected as options\n";
  214   my(%key_options) = @_;  # remaining args are options from a public key RR
  215   defined $domain && $domain ne ''
  216     or die "dkim_key: domain must not be empty: ($domain,$selector,$key)";
  217   defined $selector && $selector ne ''
  218     or die "dkim_key: selector must not be empty: ($domain,$selector,$key)";
  219   my($key_storage_ind);
  220   if (ref $key) {  # key already preprocessed and provided as an object
  221     push(@dkim_signing_keys_storage, [$key]);
  222     $key_storage_ind = $#dkim_signing_keys_storage;
  223   } else {  # assume a name of a file containing a private key in PEM format
  224     my($fname) = $key;
  225     my($pem_fh) = IO::File->new;  # open a file with a private key
  226     $pem_fh->open($fname,'<') or die "Can't open PEM file $fname: $!";
  227     my(@stat_list) = stat($pem_fh);  # soft-link friendly
  228     @stat_list or warn "Error on accessing $fname: $!";
  229     my($dev,$inode) = @stat_list;
  230     if ($dev && $inode) {
  231       for my $j (0..$#dkim_signing_keys_storage) {  # same file reused?
  232         my($k,$dv,$in,$fn) = @{$dkim_signing_keys_storage[$j]};
  233         if ($dv == $dev && $in == $inode) { $key_storage_ind = $j; last }
  234       }
  235     }
  236     if (!defined($key_storage_ind)) {
  237       # read file and store its contents as a new entry
  238       my($nbytes,$buff); $key = '';
  239       while (($nbytes=$pem_fh->read($buff,16384)) > 0) { $key .= $buff }
  240       defined $nbytes or die "Error reading key from file $fname: $!";
  241       push(@dkim_signing_keys_storage, [$key,$dev,$inode,$fname]);
  242       $key_storage_ind = $#dkim_signing_keys_storage;
  243     }
  244     $pem_fh->close or die "Error closing file $fname: $!";
  245     $key_options{k} = 'rsa'  if defined $key_options{k};  # force RSA
  246   }
  247   $domain   = lc($domain)  if !ref($domain);  # possibly a regexp
  248   $selector = lc($selector);
  249   $key_options{domain} = $domain; $key_options{selector} = $selector;
  250   $key_options{key_storage_ind} = $key_storage_ind;
  251   if (@dkim_signing_keys_list > 100) {
  252     # sorry, skip the test to avoid slow O(n^2) searches
  253   } else {
  254     !(grep { $_->{domain} eq $domain && $_->{selector} eq $selector }
  255            @dkim_signing_keys_list)
  256      or die "dkim_key: selector $selector for domain $domain already in use\n";
  257   }
  258   $key_options{key_ind} = $#dkim_signing_keys_list + 1;
  259   push(@dkim_signing_keys_list, \%key_options);  # using a list preserves order
  260 }
  261 
  262 # THE dkim_key_postprocess IS A DIRECT COPY OF THE SAME ROUTINE FROM amavisd
  263 #
  264 # Convert private keys (as strings in PEM format) into RSA objects
  265 # and do some pre-processing on @dkim_signing_keys_list entries
  266 # (may run unprivileged)
  267 #
  268 sub dkim_key_postprocess() {
  269   # convert private keys (as strings in PEM format) into RSA objects
  270   for my $ks (@dkim_signing_keys_storage) {
  271     my($pkcs1,$dev,$inode,$fname) = @$ks;
  272     if (ref($pkcs1) && UNIVERSAL::isa($pkcs1,'Crypt::OpenSSL::RSA')) {
  273       # it is already a Crypt::OpenSSL::RSA object
  274     } else {
  275       # assume a string is a private key in PEM format, convert it to RSA obj
  276       $ks->[0] = Crypt::OpenSSL::RSA->new_private_key($pkcs1);
  277     }
  278   }
  279   for my $ent (@dkim_signing_keys_list) {
  280     my($domain) = $ent->{domain};
  281     $dkim_signing_keys_by_domain{$domain} = []
  282       if !$dkim_signing_keys_by_domain{$domain};
  283   }
  284   my($any_wild); my($j) = 0;
  285   for my $ent (@dkim_signing_keys_list) {
  286     $ent->{v} = 'DKIM1'  if !defined $ent->{v};  # provide a default
  287     if (defined $ent->{n}) {  # encode n as qp-section (rfc4871, rfc2047)
  288       $ent->{n} =~ s{([\000-\037\177=;"])}{sprintf('=%02X',ord($1))}egs;
  289     }
  290     my($domain) = $ent->{domain};
  291     if (ref($domain) eq 'Regexp') {
  292       $ent->{domain_re} = $domain;
  293       $any_wild = sprintf("key#%d, %s", $j+1, $domain)  if !defined $any_wild;
  294     } elsif ($domain =~ /\*/) {
  295       # wildcarded signing domain in a key declaration, evil, asks for trouble!
  296       # support wildcards in signing domain for compatibility with dkim_milter
  297       my($regexp) = $domain;
  298       $regexp =~ s/\*{2,}/*/gs;   # collapse successive wildcards
  299       # '*' is a wildcard, quote the rest
  300       $regexp =~ s{ ([@#/.^$|*+?(){}\[\]\\]) }{$1 eq '*' ? '.*' : '\\'.$1}gex;
  301       $regexp = '^' . $regexp . '\\z';  # implicit anchors
  302       $regexp =~ s/^\^\.\*//s;    # remove leading anchor if redundant
  303       $regexp =~ s/\.\*\\z\z//s;  # remove trailing anchor if redundant
  304       $regexp = '(?:)'  if $regexp eq '';  # just in case, non-empty regexp
  305       # presence of {'domain_re'} entry lets get_dkim_key use this regexp
  306       # instead of a direct string comparision with {'domain'}
  307       $ent->{domain_re} = qr{$regexp};  # compiled regexp object
  308       $any_wild = sprintf("key#%d, %s", $j+1, $domain)  if !defined $any_wild;
  309     }
  310     # %dkim_signing_keys_by_domain entries contain lists of indices into
  311     # the @dkim_signing_keys_list of all potentially applicable signing keys.
  312     # This hash (keyed by domain name) avoids linear searching for signing
  313     # keys for all fully-specified domains in @dkim_signing_keys_list.
  314     # Wildcarded entries must still be looked up sequentially at run-time
  315     # to preserve the declared order and the 'first match wins' paradigm.
  316     # Such entries are only supported for compatibility with dkim_milter
  317     # and are evil because amavisd has no quick way of verifying that DNS RR
  318     # really exists, so signatures generated by amavisd can fail when not all
  319     # possible DNS resource records exist for wildcarded signing domains.
  320     #
  321     if (!defined($ent->{domain_re})) { # no regexp, just plain match on domain
  322       push(@{$dkim_signing_keys_by_domain{$domain}}, $j);
  323     } else {  # a wildcard in a signing domain, compatibility with dkim_milter
  324       # wildcarded signing domain potentially matches any _by_domain entry
  325       for my $d (keys %dkim_signing_keys_by_domain) {
  326         push(@{$dkim_signing_keys_by_domain{$d}}, $j);
  327       }
  328       # the '*' entry collects only wildcarded signing keys
  329       $dkim_signing_keys_by_domain{'*'} = []
  330         if !$dkim_signing_keys_by_domain{'*'};
  331       push(@{$dkim_signing_keys_by_domain{'*'}}, $j);
  332     }
  333     $j++;
  334   }
  335   do_log(0,"dkim: wildcard in signing domain (%s), may produce unverifiable ".
  336            "signatures with no published public key, avoid!", $any_wild)
  337         if $any_wild;
  338 }
  339 
  340 # THE get_dkim_key IS A DIRECT COPY OF THE SAME ROUTINE FROM amavisd
  341 #
  342 # Fetch a private DKIM signing key for a given signing domain, with its
  343 # resource-record (RR) constraints compatible with proposed signature options.
  344 # The first such key is returned as a hash; if no key is found an empty hash
  345 # is returned. When a selector (s) is given it must match the selector of
  346 # a key; when algorithm (a) is given, the key type and a hash algorithm must
  347 # match the desired use too; the service type (s) must be 'email' or '*';
  348 # when identity (i) is given it must match the granularity (g) of a key;
  349 #
  350 # sign.opts.     key options
  351 # ----------     -----------
  352 #  d         =>  domain
  353 #  s         =>  selector
  354 #  a         =>  k, h(list)
  355 #  i         =>  g, t=s
  356 #
  357 sub get_dkim_key(@) {
  358   @_ % 2 == 0 or die "get_dkim_key: a list of pairs is expected as query opts";
  359   my(%options) = @_;  # signature options (v, a, c, d, h, i, l, q, s, t, x, z),
  360     # of which d is required, while s, a and t are optional but taken into
  361     # account in searching for a compatible key - the rest are ignored
  362   my(%key_options);
  363   my($domain) = $options{d};
  364   defined $domain && $domain ne ''
  365     or die "get_dkim_key: domain is required, but tag 'd' is missing";
  366   $domain = lc($domain);
  367   my(@indices) = $dkim_signing_keys_by_domain{$domain} ?
  368                    @{$dkim_signing_keys_by_domain{$domain}} :
  369                  $dkim_signing_keys_by_domain{'*'} ?
  370                    @{$dkim_signing_keys_by_domain{'*'}} : ();
  371   if (@indices) {
  372     my($selector) = $options{s};
  373     $selector = $selector eq '' ? undef : lc($selector)  if defined $selector;
  374     local($1,$2);
  375     my($keytype,$hashalg) =
  376       defined $options{a} && $options{a} =~ /^([a-z0-9]+)-(.*)\z/is ? ($1,$2)
  377                                                               : ('rsa',undef);
  378     my($identity_localpart,$identity_domain) =
  379       !defined($options{i}) ? () : split_address($options{i});
  380     $identity_localpart = ''  if !defined $identity_localpart;
  381     $identity_domain    = ''  if !defined $identity_domain;
  382     # find the first key (associated with a domain) with compatible options
  383     for my $j (@indices) {
  384       my($ent) = $dkim_signing_keys_list[$j];
  385       next unless defined $ent->{domain_re} ? $domain =~ $ent->{domain_re}
  386                                             : $domain eq $ent->{domain};
  387       next if defined $selector && $ent->{selector} ne $selector;
  388       next if $keytype ne (exists $ent->{k} ? $ent->{k} : 'rsa');
  389       next if exists $ent->{s} &&
  390               !(grep { $_ eq '*' || $_ eq 'email' } split(/:/, $ent->{s}) );
  391       next if defined $hashalg && exists $ent->{'h'} &&
  392               !(grep { $_ eq $hashalg } split(/:/, $ent->{'h'}) );
  393       if (defined($options{i})) {
  394         if (lc($identity_domain) eq $domain) {
  395           # ok
  396         } elsif (exists $ent->{t} && (grep {$_ eq 's'} split(/:/,$ent->{t}))) {
  397           next;  # no subdomains allowed
  398         }
  399         if (!exists($ent->{g}) || $ent->{g} eq '*') {
  400           # ok
  401         } elsif ($ent->{g} =~ /^ ([^*]*) \* (.*) \z/xs) {
  402           next if $identity_localpart !~ /^ \Q$1\E .* \Q$2\E \z/xs;
  403         } else {
  404           next if $identity_localpart ne $ent->{g};
  405         }
  406       }
  407       %key_options = %$ent;  last;  # found a suitable match
  408     }
  409   }
  410   if (defined $key_options{key_storage_ind}) {
  411     # obtain actual key from @dkim_signing_keys_storage
  412     ($key_options{key}) =
  413       @{$dkim_signing_keys_storage[$key_options{key_storage_ind}]};
  414   }
  415   %key_options;
  416 }
  417 
  418 sub proto_encode($@) {
  419   my($attribute_name,@strings) = @_; local($1);
  420   for ($attribute_name,@strings) {
  421     # just in case, handle non-octet characters:
  422     s/([^\000-\377])/sprintf('\\x{%04x}',ord($1))/eg and
  423       do_log(-1,"proto_encode: non-octet character encountered: %s", $_);
  424   }
  425   $attribute_name =~    # encode all but alfanumerics, . _ + -
  426     s/([^0-9a-zA-Z._+-])/sprintf("%%%02x",ord($1))/eg;
  427   for (@strings) {      # encode % and nonprintables
  428     s/([^\041-\044\046-\176])/sprintf("%%%02x",ord($1))/eg;
  429   }
  430   $attribute_name . '=' . join(' ',@strings);
  431 }
  432 
  433 sub proto_decode($) {
  434   my($str) = @_; local($1);
  435   $str =~ s/%([0-9a-fA-F]{2})/pack("C",hex($1))/egs;
  436   $str;
  437 }
  438 
  439 sub split_localpart($$) {
  440   my($localpart, $delimiter) = @_;
  441   my($owner_request_special) = 1;  # configurable ???
  442   my($extension); local($1,$2);
  443   if ($localpart =~ /^(postmaster|mailer-daemon|double-bounce)\z/i) {
  444     # do not split these, regardless of what the delimiter is
  445   } elsif ($delimiter eq '-' && $owner_request_special &&
  446            $localpart =~ /^owner-.|.-request\z/si) {
  447     # don't split owner-foo or foo-request
  448   } elsif ($localpart =~ /^(.+?)(\Q$delimiter\E.*)\z/s) {
  449     ($localpart, $extension) = ($1, $2);  # extension includes a delimiter
  450     # do not split the address if the result would have a null localpart
  451   }
  452   ($localpart, $extension);
  453 }
  454 
  455 sub unique_ref(@) {
  456   my($r) = @_ == 1 && ref($_[0]) ? $_[0] : \@_;  # accept list, or a list ref
  457   my(%seen);  my(@result) = grep { defined($_) && !$seen{$_}++ } @$r;
  458   \@result;
  459 }
  460 
  461 sub make_query_keys($$$;$) {
  462   my($addr,$at_with_user,$include_bare_user,$append_string) = @_;
  463   my($localpart,$domain) = split_address($addr); $domain = lc($domain);
  464   my($saved_full_localpart) = $localpart;
  465   $localpart = lc($localpart);  ### if !c('localpart_is_case_sensitive');
  466   # chop off leading @, and trailing dots
  467   local($1);
  468   $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  469   my($extension); my($delim) = '+';  ### c('recipient_delimiter');
  470   if ($delim ne '') {
  471     ($localpart,$extension) = split_localpart($localpart,$delim);
  472     # extension includes a delimiter since amavisd-new-2.5.0!
  473   }
  474   $extension = ''  if !defined $extension;  # mute warnings
  475   my($append_to_user,$prepend_to_domain) = $at_with_user ? ('@','') : ('','@');
  476   my(@keys);  # a list of query keys
  477   push(@keys, $addr);                        # as is
  478   push(@keys, $localpart.$extension.'@'.$domain)
  479     if $extension ne '';                     # user+foo@example.com
  480   push(@keys, $localpart.'@'.$domain);       # user@example.com
  481   if ($include_bare_user) {  # typically enabled for local users only
  482     push(@keys, $localpart.$extension.$append_to_user)
  483       if $extension ne '';                   # user+foo(@)
  484     push(@keys, $localpart.$append_to_user); # user(@)
  485   }
  486   push(@keys, $prepend_to_domain.$domain);   # (@)sub.example.com
  487   if ($domain =~ /\[/) {     # don't split address literals
  488     push(@keys, $prepend_to_domain.'.');     # (@).
  489   } else {
  490     my(@dkeys); my($d) = $domain;
  491     for (;;) {               # (@).sub.example.com (@).example.com (@).com (@).
  492       push(@dkeys, $prepend_to_domain.'.'.$d);
  493       last  if $d eq '';
  494       $d = ($d =~ /^([^.]*)\.(.*)\z/s) ? $2 : '';
  495     }
  496     if (@dkeys > 10) { @dkeys = @dkeys[$#dkeys-9 .. $#dkeys] }  # sanity limit
  497     push(@keys,@dkeys);
  498   }
  499   if (defined $append_string && $append_string ne '') {
  500     $_ .= $append_string  for @keys;
  501   }
  502   my($keys_ref) = unique_ref(\@keys);  # remove duplicates
  503   ll(5) && do_log(5,"query_keys: %s", join(', ',@$keys_ref));
  504   # the rhs replacement strings are similar to what would be obtained
  505   # by lookup_re() given the following regular expression:
  506   # /^( ( ( [^\@]*? ) ( \Q$delim\E [^\@]* )? ) (?: \@ (.*) ) )$/xs
  507   my($rhs) = [   # a list of right-hand side replacement strings
  508     $addr,                  # $1 = User+Foo@Sub.Example.COM
  509     $saved_full_localpart,  # $2 = User+Foo
  510     $localpart,             # $3 = user
  511     $extension,             # $4 = +foo
  512     $domain,                # $5 = sub.example.com
  513   ];
  514   ($keys_ref, $rhs);
  515 }
  516 
  517 sub lookup_hash($$;$%) {
  518   my($addr, $hash_ref,$get_all,%options) = @_;
  519   ref($hash_ref) eq 'HASH'
  520     or die "lookup_hash: arg2 must be a hash ref: $hash_ref";
  521   local($1,$2,$3,$4); my(@matchingkey,@result); my($append_string);
  522   $append_string = $options{AppendStr}  if defined $options{AppendStr};
  523   my($keys_ref,$rhs_ref) = make_query_keys($addr,1,1,$append_string);
  524   for my $key (@$keys_ref) {   # do the search
  525     if (exists $$hash_ref{$key}) {  # got it
  526       push(@result,$$hash_ref{$key}); push(@matchingkey,$key);
  527       last  if !$get_all;
  528     }
  529   }
  530   # do the right-hand side replacements if any $n, ${n} or $(n) is specified
  531   for my $r (@result) {  # remember that $r is just an alias to array elements
  532     if (defined($r) && !ref($r) && index($r,'$') >= 0) { # plain string with $
  533       my($any) = $r =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) }
  534                         { my($j)=$2+$3+$4; $j<1 ? '' : $rhs_ref->[$j-1] }gxse;
  535       # bring taintedness of input to the result
  536       $r .= substr($addr,0,0)  if $any;
  537     }
  538   }
  539   if (!$get_all) { ($result[0], $matchingkey[0]) }
  540   else           { (\@result,   \@matchingkey)   }
  541 }
  542 
  543 sub lookup2($$$%) {
  544   my($get_all, $addr, $tables_ref, %options) = @_;
  545   (@_ - 3) % 2 == 0 or die "lookup2: options argument not in pairs (not hash)";
  546   my($label, @result,@matchingkey);
  547   for my $tb (!$tables_ref ? () : @$tables_ref) {
  548     my($t) = ref($tb) eq 'REF' ? $$tb : $tb; # allow one level of indirection
  549     if (!ref($t) || ref($t) eq 'SCALAR') {   # a scalar always matches
  550       my($r) = ref($t) ? $$t : $t;  # allow direct or indirect reference
  551       if (defined $r) {
  552         do_log(5,'lookup: (scalar) matches, result="%s"', $r);
  553         push(@result,$r); push(@matchingkey,"(constant:$r)");
  554       }
  555     } elsif (ref($t) eq 'HASH') {
  556       my($r,$mk);
  557       ($r,$mk) = lookup_hash($addr,$t,$get_all,%options)  if %$t;
  558       if (!defined $r)  {}
  559       elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
  560       elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
  561     } else {
  562       die "TROUBLE: lookup table not implemented for object: " . ref($t);
  563     }
  564     last  if @result && !$get_all;
  565   }
  566   if (!$get_all) { ($result[0], $matchingkey[0]) }
  567   else           { (\@result,   \@matchingkey)   }
  568 }
  569 
  570 sub parse_quoted_rfc2821($$) {
  571   my($addr,$unquote) = @_;
  572   # the angle-bracket stripping is not really a duty of this subroutine,
  573   # as it should have been already done elsewhere, but we allow it here anyway:
  574   $addr =~ s/^\s*<//s;  $addr =~ s/>\s*\z//s;  # tolerate unmatched angle brkts
  575   local($1,$2); my($source_route,$localpart,$domain) = ('','','');
  576   # RFC 2821: so-called "source route" MUST BE accepted,
  577   #           SHOULD NOT be generated, and SHOULD be ignored.
  578   #           Path = "<" [ A-d-l ":" ] Mailbox ">"
  579   #           A-d-l = At-domain *( "," A-d-l )
  580   #           At-domain = "@" domain
  581   if (index($addr,':') >= 0 &&  # triage before more testing for source route
  582       $addr =~ m{^ (       [ \t]* \@ (?: [0-9A-Za-z.!\#\$%&*/^{}=_+-]* |
  583                                    \[ (?: \\. | [^\]\\] ){0,999} \] ) [ \t]*
  584                      (?: , [ \t]* \@ (?: [0-9A-Za-z.!\#\$%&*/^{}=_+-]* |
  585                                    \[ (?: \\. | [^\]\\] ){0,999} \] ) [ \t]* )*
  586                      : [ \t]* ) (.*) \z }xs)
  587   { # NOTE: we are quite liberal on allowing whitespace around , and : here,
  588     # and liberal in allowed character set and syntax of domain names,
  589     # we mainly avoid stop-characters in the domain names of source route
  590     $source_route = $1; $addr = $2;
  591   }
  592   if ($addr =~ m{^ ( .*? )
  593                  ( \@ (?: [^\@\[\]]+ | \[ (?: \\. | [^\]\\] ){0,999} \]
  594                           | [^\@] )* )
  595                  \z}xs) {
  596     ($localpart,$domain) = ($1,$2);
  597   } else {
  598     ($localpart,$domain) = ($addr,'');
  599   }
  600   $localpart =~ s/ " | \\ (.) | \\ \z /$1/xsg  if $unquote; # undo quoted-pairs
  601   ($source_route, $localpart, $domain);
  602 }
  603 
  604 sub unquote_rfc2821_local($) {
  605   my($mailbox) = @_;
  606   my($source_route,$localpart,$domain) = parse_quoted_rfc2821($mailbox,1);
  607   # make address with '@' in the localpart but no domain (like <"aa@bb.com"> )
  608   # distinguishable from <aa@bb.com> by representing it as aa@bb.com@ in
  609   # unquoted form; (it still obeys all regular rules, it is not a dirty trick)
  610   $domain = '@'  if $domain eq '' && $localpart ne '' && $localpart =~ /\@/;
  611   $localpart . $domain;
  612 }
  613 
  614 #
  615 # ======================================================================
  616 # Code above is copied from amavisd; some day it should be factored out.
  617 # Code from here on is specific to amavisd-signer.
  618 # ======================================================================
  619 #
  620 
  621 # process a request to choose a signing key;
  622 #
  623 sub choose_key_request($) {
  624   my($attr) = @_;
  625   my(@results);
  626   my(%sig_options);  # signature options, and constraints for choosing a key
  627   my(%key_options);  # options associated with a signing key
  628   my(@tried_domains);  # used for logging a failure
  629   my($chosen_addr,$chosen_addr_src);
  630   my($cand) = $attr->{candidate};
  631   my(@candidates) = !defined $cand ? () : !ref $cand ? $cand : @$cand;
  632   my($sobm) = \@dkim_signature_options_bysender_maps;
  633   for my $pair (@candidates) {
  634     my($addr_src,$addr) = split(' ',$pair,2);
  635     $addr = unquote_rfc2821_local($addr);
  636     my($addr_localpart,$addr_domain) = split_address($addr);
  637     $addr_domain = lc($addr_domain);
  638     my($dkim_options_ref,$mk_ref) = lookup2(1,$addr,$sobm);
  639     $dkim_options_ref = []  if !defined $dkim_options_ref;  #***?
  640     # place catchall default(s) at the end of the list of options;
  641     push(@$dkim_options_ref, { c => 'relaxed/simple', a => 'rsa-sha256' });
  642     %sig_options = ();  # signature options:
  643                   # (v), a, (b), (bh), c, d, (h), i, (l), q, s, (t), x, (z)
  644     # traverse from specific to general, first match wins
  645     for my $opts_hash_ref (@$dkim_options_ref) {
  646       while (my($k,$v) = each(%$opts_hash_ref))
  647         { $sig_options{$k} = $v  if !exists($sig_options{$k}) }
  648     }
  649     # a default for a signing domain is a domain of each tried address
  650     if (!exists($sig_options{d}))
  651       { my($d) = $addr_domain; $d =~ s/^\@//; $sig_options{d} = $d }
  652     push(@tried_domains, $sig_options{d});
  653     ll(5) && do_log(5, "signature options for %s(%s): %s", $addr,$addr_src,
  654             join('; ', map { $_.'='.$sig_options{$_} } keys %sig_options));
  655     # find a private key associated with a signing domain and selector,
  656     # and meeting constraints
  657     %key_options = get_dkim_key(%sig_options)
  658       if defined $sig_options{d} && $sig_options{d} ne '';
  659     my($key) = $key_options{key};
  660     if (defined $key && $key ne '') {  # found; copy the key and its options
  661       $sig_options{key} = $key;  $sig_options{s} = $key_options{selector};
  662       $chosen_addr = $addr; $chosen_addr_src = $addr_src;
  663       last;
  664     }
  665   }
  666   # if any signature options were specified in the request and not overruled
  667   # by more specific ones here, copy them to the resulting set of sig options
  668   for my $opt (keys %$attr) {
  669     if ($opt =~ /^sig\.(.+)\z/) {
  670       $sig_options{$1} = $attr->{$opt}  if !exists($sig_options{$1});
  671     }
  672   }
  673   ll(5) && do_log(5, "sig options: %s",
  674              join('; ', map { $_.'='.$sig_options{$_} } keys %sig_options));
  675   my(%key_options);
  676   if (defined $sig_options{d} && $sig_options{d} ne '') {
  677     %key_options = get_dkim_key(%sig_options);
  678   }
  679   do_log(5, "key options: %s is %s",
  680             $_, $key_options{$_}) for keys %key_options;
  681   my($s) = $key_options{'selector'};
  682   my($d) = $key_options{'domain'};
  683   $sig_options{'s'} = $s;
  684   $sig_options{'d'} = $d;
  685   delete $sig_options{'key'};  # no use of key ref in the protocol
  686   for my $opt (sort keys %sig_options) {
  687     if (defined $sig_options{$opt}) {
  688       push(@results, proto_encode('sig.'.$opt, $sig_options{$opt}));
  689     }
  690   }
  691   # optional information if available: client may log it, or use for debugging
  692   if (defined $chosen_addr_src && defined $chosen_addr) {
  693     push(@results, proto_encode('chosen_candidate',
  694                                 $chosen_addr_src, $chosen_addr));
  695   }
  696   \@results;
  697 }
  698 
  699 # sign a digest code using the specified algorithm and a private signing key
  700 #
  701 sub dkim_rsa_sign($$$) {
  702   my($digest,$alg_name,$key) = @_;
  703   my($result);
  704   $digest = ''   if !defined $digest;
  705   $alg_name = '' if !defined $alg_name;
  706   if (defined $key && $key ne '') {
  707     my($key) = Mail::DKIM::PrivateKey->load(Cork => $key);
  708     $key  or die "no key available\n";
  709     $result = $key->sign_digest($alg_name,$digest);
  710   }
  711   $result;
  712 }
  713 
  714 # process a request to sign the supplied digest with a selected key
  715 #
  716 # presence of the 'b' attribute in the result indicates success,
  717 # otherwise the result is treated as signature unavailable
  718 #
  719 sub sign_request($) {
  720   my($attr) = @_;
  721   my(@results, $reason, $sig);
  722   my($digest, $digest_alg, $selector, $domain) =
  723     @$attr{qw(digest digest_alg s d)};
  724   if (!defined $digest || $digest eq '') {
  725     $reason = 'cannot sign, digest not provided, nothing to sign';
  726   } elsif (!defined $digest_alg || $digest_alg eq '') {
  727     $reason = 'cannot sign, digest algorithm name not provided';
  728   } elsif (!defined $domain || $domain eq '') {
  729     $reason = 'cannot sign, signing domain not provided';
  730   } elsif (!defined $selector || $selector eq '') {
  731     $reason = 'cannot sign, selector not provided';
  732   } else {
  733     my(%sig_options);  # signature options: v, a, c, d, h, i, l, q, s, t, x, z
  734     $sig_options{s} = $selector;
  735     $sig_options{d} = $domain;
  736     my(%key_options) = get_dkim_key(%sig_options);
  737     if (!defined $key_options{key}) {
  738       $reason = 'cannot sign, signing key not available';
  739     } else {
  740       do_log(5, "key options: %s is %s",
  741                 $_, $key_options{$_})  for keys %key_options;
  742       eval {
  743         $sig = dkim_rsa_sign(decode_base64($digest),
  744                              $digest_alg, $key_options{key});  1;
  745       } or do {
  746         my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
  747         do_log(0, "signing failed: %s", $eval_stat);
  748         $reason = 'cannot sign: ' . $eval_stat;
  749       };
  750       push(@results, proto_encode('d', $key_options{'domain'}));
  751       push(@results, proto_encode('s', $key_options{'selector'}));
  752     }
  753   }
  754   if (defined $sig && $sig ne '') {
  755     push(@results, proto_encode('b', encode_base64($sig,'')));
  756   } else {
  757     $reason = 'cannot sign: signing failed'  if !defined $reason;
  758     push(@results, proto_encode('reason', $reason));
  759   }
  760   \@results;
  761 }
  762 
  763 # process the request received from amavisd
  764 #
  765 sub do_the_request($) {
  766   my($attr) = @_;
  767   ll(2) && do_log(2, "got: %s", join('; ', map {
  768                       my($k) = $_; my($v) = $attr->{$k};
  769                       map { $k.'='.$_ } (!ref $v ? $v : @$v) } keys %$attr));
  770   my(@results);
  771   my($req_id) = $attr->{request_id};
  772   my($log_id) = $attr->{log_id};
  773   push(@results, proto_encode('request_id', $req_id))  if defined $req_id;
  774   push(@results, proto_encode('log_id',     $log_id))  if defined $log_id;
  775   my($request_type) = $attr->{request};
  776   $request_type = ''  if !defined $request_type;
  777   if ($request_type eq 'choose_key') {
  778     push(@results, @{choose_key_request($attr)});
  779   } elsif ($request_type eq 'sign') {
  780     push(@results, @{sign_request($attr)});
  781   } else {
  782     push(@results, proto_encode('reason', 'unknown request type'));
  783     do_log(2, "got: ignoring request: %s", $request_type);
  784   }
  785   ll(1) && do_log(1, "response: %s", join('; ', @results));
  786   do_log(5, "");
  787   \@results;
  788 }
  789 
  790 # IO::Multiplex -style callback hook
  791 #
  792 sub mux_connection {
  793   my($self,$mux,$fh) = @_;
  794   do_log(3, "client %s just connected", $self->{peeraddr});
  795   $self->{attr} = {};
  796 }
  797 
  798 # the mux_connection callback is guaranteed to have already been run once
  799 #
  800 sub mux_input {
  801   my($self,$mux,$fh,$in_ref) = @_;
  802   my $attr = $self->{attr};
  803   do_log(5, "input from %s ready", $self->{peeraddr});
  804 
  805   # process each line in the input, leaving partial lines in the input buffer
  806   local($1,$2); my($quit) = 0;
  807   while ($$in_ref =~ s/^(.*?)\015?\012//) {
  808     my($ln) = $1;
  809     if ($ln eq '') {  # empty line indicates end of a request
  810       my($results_ref) = do_the_request($attr);
  811       print(join('', map { $_."\015\012" } (@$results_ref,'')))
  812         or do_log(0,"mux_input: error writing a response to socket" );
  813       %$attr = ();  # reset, awaiting next request in the same session
  814     } elsif ($ln =~ /^ ([^=\000\012]*?) (?: = | : [ \t]* ) (.*) \z/xsi) {
  815       my($attr_name) = proto_decode($1);
  816       my($attr_val)  = proto_decode($2);
  817       if (!exists $attr->{$attr_name}) {
  818         $attr->{$attr_name} = $attr_val;  # simple scalar for one-time attrs
  819       } elsif (!ref($attr->{$attr_name})) {  # multiple, convert to a list
  820         $attr->{$attr_name} = [ $attr->{$attr_name}, $attr_val ];
  821       } else {  # append to a list of same-name attributes
  822         push(@{$attr->{$attr_name}}, $attr_val);
  823       }
  824     } else {
  825       do_log(0, "mux_input: ignored line: %s", $ln);
  826     }
  827   }
  828   close(STDOUT)  if $quit;
  829 }
  830 
  831 
  832 #
  833 # Main program starts here (after initializations near the top of this file)
  834 #
  835 
  836 dkim_key_postprocess();
  837 
  838 # set up a Net::Server configuration
  839 $server = AmavisSigner->new({
  840   # limit socket bind (e.g. to the loopback interface)
  841   host => (!defined $inet_socket_bind || $inet_socket_bind eq '' ? '*'
  842                                                         : $inet_socket_bind),
  843   port => \@listen_sockets,  # listen on these sockets (Unix or inet)
  844   listen => $listen_queue_size,  # undef for a default
  845   user  => ($> == 0 || $< == 0) ? $daemon_user  : undef,
  846   group => ($> == 0 || $< == 0) ? $daemon_group : undef,
  847   background => $daemonize ? 1 : undef,
  848   setsid     => $daemonize ? 1 : undef,
  849   chroot     => $daemon_chroot_dir ne '' ? $daemon_chroot_dir : undef,
  850   pid_file   => $pid_file,
  851   log_file   => $daemonize ? 'Sys::Syslog' : undef,
  852   syslog_ident    => $syslog_ident,
  853   syslog_facility => $syslog_facility,
  854   syslog_logsock  => 'native',
  855   # 0=err, 1=warning, 2=notice, 3=info, 4=debug
  856   log_level => $log_level >= 5 ? 4 : 2,
  857 });
  858 
  859 $server->run;  # transferring control to Net::Server
  860 exit 1;  # shouldn't get here
  861 
  862 # TODO: pkcs11 URI
  863 # In order to use a key an application needs the path to the PKCS11 lib,
  864 # the key ID, username, pin and the slot number
  865 #
  866 # http://blogs.sun.com/janp/entry/pkcs_11_engine_patch_including
  867 #   pkcs11:[object=<label>]  # object (key) label, eg. "mykey"
  868 #   [;token=<label>]         # token label
  869 #   [;manuf=<label>]         # manufacturer ID
  870 #   [;serial=<label>]        # serial number of the token
  871 #   [;model=<label>]         # token model
  872 #   [;objecttype=(public|private|cert|data)]
  873 #   [;passphrasedialog=(builtin|exec:<file>)]
  874 #
  875 # alternative:
  876 #   pkcs11:///path/to/pkcs11/lib?slot=0&id=123
  877 #   file:///path/to/pem/file
  878 #
  879 # SEE: http://blog.nominet.org.uk/tech/category/crypto/