File: amavisd-signer

package info (click to toggle)
amavisd-new 1:2.11.0-6.1
  • links: PTS, VCS
  • area: main
  • in suites: buster, sid
  • size: 12,432 kB
  • sloc: perl: 33,770; sh: 523; sql: 158; makefile: 8
file content (879 lines) | stat: -rwxr-xr-x 37,735 bytes parent folder | download | duplicates (3)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
#!/usr/bin/perl -T

#------------------------------------------------------------------------------
# This is amavisd-signer, a DKIM signing service daemon for amavisd.
# It uses an AM.PDP protocol lookalike to receive a request from amavisd
# and provides two services: choosing a signing key, and signing a
# message digest with a chosen DKIM private key.
#
# Author: Mark Martinec <Mark.Martinec@ijs.si>
#
# Copyright (c) 2010-2014, Mark Martinec
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
# 1. Redistributions of source code must retain the above copyright notice,
#    this list of conditions and the following disclaimer.
# 2. 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.
#
# 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 OWNER 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.
#
# The views and conclusions contained in the software and documentation are
# those of the authors and should not be interpreted as representing official
# policies, either expressed or implied, of the Jozef Stefan Institute.

# (the above license is the 2-clause BSD license, also known as
#  a "Simplified BSD License", and pertains to this program only)
#
# Patches and problem reports are welcome.
# The latest version of this program is available at:
#   http://www.ijs.si/software/amavisd/
#------------------------------------------------------------------------------

# Using a separate signing service (which may run under a dedicated UID or
# GID or as root, having exclusive access to private keys) releaves amavisd
# process from needing to have access to private keys. Separating roles can
# provide improved protection for DKIM private keys, and/or can provide more
# flexibility in choosing a signing key.
#
# Usage:
#   amavisd-signer &

package AmavisSigner;

use strict;
use re 'taint';
use warnings FATAL => 'utf8';
no warnings 'uninitialized';

use Sys::Syslog;  # used by Net::Server for logging
use MIME::Base64;
use Mail::DKIM;
use Mail::DKIM::PrivateKey;

use Net::Server 0.91;
use Net::Server::Multiplex;
use vars qw(@ISA);
@ISA = qw(Net::Server::Multiplex);

use vars qw(
  $VERSION $log_level
  %dkim_signing_keys_by_domain
  @dkim_signing_keys_list @dkim_signing_keys_storage
  @dkim_signature_options_bysender_maps
  $daemon_chroot_dir $daemon_user $daemon_group $pid_file $daemonize
  $inet_socket_bind @listen_sockets $listen_queue_size
  $syslog_ident $syslog_facility
);

$VERSION = 1.001;  # 20100730

#
# Please adjust the following settings as necessary:
#

$daemon_user  = 'amavis';
$daemon_group = 'amavis';
# $daemon_chroot_dir = '/var/lib/amavis';   # chroot directory or undef

# $daemonize = 1;

$log_level = 2;  # 0..5
$syslog_facility = 'mail';
$syslog_ident = 'amavisd-signer';

# the $inet_socket_bind and @listen_sockets should correspond to a
# setting $dkim_signing_service in amavisd.conf :
$inet_socket_bind = '127.0.0.1';
@listen_sockets = ( 20203 );
$listen_queue_size = undef;  # uses a default

# Load all available private keys and supply their public key RR constraints.
# Arguments are a domain, a selector, a key (a file name of a private key in
# PEM format), followed by optional attributes/constraints (tags, represented
# here as Perl hash key/value pairs) which are allowed by RFC 4871 in a public
# key resource record (v, g, h, k, n, s, t), of which only g, h, k, s and t
# are considered to be constraints limiting the choice of a signing key.
#
#         signing domain   selector     private key              options
#          -------------   --------     ----------------------   ----------
# dkim_key('example.org', 'abc',       '/var/db/dkim/a.key.pem');
# dkim_key('example.org', 'yyy',       '/var/db/dkim/b.key.pem', t=>'s');
# dkim_key('example.org', 'zzz',       '/var/db/dkim/b.key.pem', h=>'sha256');
# dkim_key('example.com', 'sel-2008',  '/var/db/dkim/sel-example-com.key.pem',
#          t=>'s:y', g=>'*', k=>'rsa', h=>'sha256:sha1', s=>'email',
#          n=>'testing; 1, 2');
# dkim_key('guest.example.com', 'g',    '/var/db/dkim/g-guest-ex-com.key.pem');
# dkim_key('mail.example.com', 'notif', '/var/db/dkim/notif-mail.key.pem');

# @dkim_signature_options_bysender_maps maps author/sender addresses or
# domains to signature tags/requirements; possible signature tags according
# to RFC 4871 are: (v), a, (b), (bh), c, d, (h), i, l, q, s, (t), x, z;
# of which the following are determined implicitly: v, b, bh, h, t
# (tag h is controlled by %signed_header_fields);  currently ignored tags
# are l and z;  instead of an absolute expiration time (tag x) one may use
# a pseudo tag 'ttl' to specify a relative expiration time in seconds, which
# is converted to an absolute expiration time prior to signing: x = t + ttl;
# a built-in default is provided for each tag if no better match is found
#
# @dkim_signature_options_bysender_maps = ( {
#   'postmaster@mail.example.com' => { a => 'rsa-sha1', ttl =>  7*24*3600 },
#   'spam-reporter@example.com'   => { a => 'rsa-sha1', ttl =>  7*24*3600 },
#   'mail.example.com'            => { a => 'rsa-sha1', ttl => 10*24*3600 },
#   # explicit 'd' forces a third-party signature on foreign (hosted) domains
#   'guest.example'               => { d => 'guest.example.com' },
#   '.example.com'                => { d => 'example.com' },
#   # catchall defaults
#   '.' => { a => 'rsa-sha256', c => 'relaxed/simple', ttl => 30*24*3600 },
#   # 'd' defaults to a domain of an author/sender address,
#   # 's' defaults to whatever selector is offered by a matching key
# } );


#
# No further user-configurable settings below (but feel free
# to customize code in choose_key_request() or replace it altogether.
#

sub ll($) {
  my($level) = @_;
  $level <= $log_level;
}

my($server);  # a Net::Server object
sub do_log($$;@) {
  my($level, $errmsg, @args) = @_;
  $errmsg = sprintf($errmsg,@args)  if @args;
  if ($level <= $log_level) {
    my($prio);  # Net::Server logging priority
    # 0=err, 1=warning, 2=notice, 3=info, 4=debug
    if    ($level >=  3) { $prio = 4 }
    elsif ($level >=  0) { $prio = 2 }
    elsif ($level >= -1) { $prio = 1 }
    else                 { $prio = 0 }
    $server->log($prio, sanitize_str($errmsg));
    # Net::Server directs STDERR to the log_file
    # print STDERR sanitize_str($errmsg)."\n";
  }
}

sub sanitize_str {
  my($str, $keep_eol) = @_;
  my(%map) = ("\r" => '\\r', "\n" => '\\n', "\f" => '\\f', "\t" => '\\t',
              "\b" => '\\b', "\e" => '\\e', "\\" => '\\\\');
  if ($keep_eol) {
    $str =~ s/([^\012\040-\133\135-\176])/  # and \240-\376 ?
              exists($map{$1}) ? $map{$1} :
                     sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/eg;
  } else {
    $str =~ s/([^\040-\133\135-\176])/      # and \240-\376 ?
              exists($map{$1}) ? $map{$1} :
                     sprintf(ord($1)>255 ? '\\x{%04x}' : '\\%03o', ord($1))/eg;
  }
  $str;
}

sub split_address($) {
  my($mailbox) = @_;  local($1,$2);
  $mailbox =~ /^ (.*?) ( \@ (?:  \[  (?: \\. | [^\]\\] ){0,999} (?: \] | \z)
                              |  [^\[\@] )*
                       ) \z/xs ? ($1, $2) : ($mailbox, '');
}

# THE dkim_key IS A DIRECT COPY OF THE SAME ROUTINE FROM amavisd
#
# Store a private DKIM signing key for a given domain and selector.
# The argument $key can be a Mail::DKIM::PrivateKey object or a file
# name containing a key in a PEM format (e.g. as generated by openssl).
# For compatibility with dkim_milter the signing domain can include a '*'
# as a wildcard - this is not recommended as this way amavisd could produce
# signatures which have no corresponding public key published in DNS.
# The proper way is to have one dkim_key entry for each published DNS RR.
# Optional arguments can provide additional information about the resource
# record (RR) of a public key, i.e. its options according to RFC 4871.
# The subroutine is typically called from a configuration file, once for
# each signing key available.
#
sub dkim_key($$$;@) {
  my($domain,$selector,$key) = @_;  shift; shift; shift;
  @_%2 == 0 or die "dkim_key: a list of key/value pairs expected as options\n";
  my(%key_options) = @_;  # remaining args are options from a public key RR
  defined $domain && $domain ne ''
    or die "dkim_key: domain must not be empty: ($domain,$selector,$key)";
  defined $selector && $selector ne ''
    or die "dkim_key: selector must not be empty: ($domain,$selector,$key)";
  my($key_storage_ind);
  if (ref $key) {  # key already preprocessed and provided as an object
    push(@dkim_signing_keys_storage, [$key]);
    $key_storage_ind = $#dkim_signing_keys_storage;
  } else {  # assume a name of a file containing a private key in PEM format
    my($fname) = $key;
    my($pem_fh) = IO::File->new;  # open a file with a private key
    $pem_fh->open($fname,'<') or die "Can't open PEM file $fname: $!";
    my(@stat_list) = stat($pem_fh);  # soft-link friendly
    @stat_list or warn "Error on accessing $fname: $!";
    my($dev,$inode) = @stat_list;
    if ($dev && $inode) {
      for my $j (0..$#dkim_signing_keys_storage) {  # same file reused?
        my($k,$dv,$in,$fn) = @{$dkim_signing_keys_storage[$j]};
        if ($dv == $dev && $in == $inode) { $key_storage_ind = $j; last }
      }
    }
    if (!defined($key_storage_ind)) {
      # read file and store its contents as a new entry
      my($nbytes,$buff); $key = '';
      while (($nbytes=$pem_fh->read($buff,16384)) > 0) { $key .= $buff }
      defined $nbytes or die "Error reading key from file $fname: $!";
      push(@dkim_signing_keys_storage, [$key,$dev,$inode,$fname]);
      $key_storage_ind = $#dkim_signing_keys_storage;
    }
    $pem_fh->close or die "Error closing file $fname: $!";
    $key_options{k} = 'rsa'  if defined $key_options{k};  # force RSA
  }
  $domain   = lc($domain)  if !ref($domain);  # possibly a regexp
  $selector = lc($selector);
  $key_options{domain} = $domain; $key_options{selector} = $selector;
  $key_options{key_storage_ind} = $key_storage_ind;
  if (@dkim_signing_keys_list > 100) {
    # sorry, skip the test to avoid slow O(n^2) searches
  } else {
    !(grep { $_->{domain} eq $domain && $_->{selector} eq $selector }
           @dkim_signing_keys_list)
     or die "dkim_key: selector $selector for domain $domain already in use\n";
  }
  $key_options{key_ind} = $#dkim_signing_keys_list + 1;
  push(@dkim_signing_keys_list, \%key_options);  # using a list preserves order
}

# THE dkim_key_postprocess IS A DIRECT COPY OF THE SAME ROUTINE FROM amavisd
#
# Convert private keys (as strings in PEM format) into RSA objects
# and do some pre-processing on @dkim_signing_keys_list entries
# (may run unprivileged)
#
sub dkim_key_postprocess() {
  # convert private keys (as strings in PEM format) into RSA objects
  for my $ks (@dkim_signing_keys_storage) {
    my($pkcs1,$dev,$inode,$fname) = @$ks;
    if (ref($pkcs1) && UNIVERSAL::isa($pkcs1,'Crypt::OpenSSL::RSA')) {
      # it is already a Crypt::OpenSSL::RSA object
    } else {
      # assume a string is a private key in PEM format, convert it to RSA obj
      $ks->[0] = Crypt::OpenSSL::RSA->new_private_key($pkcs1);
    }
  }
  for my $ent (@dkim_signing_keys_list) {
    my($domain) = $ent->{domain};
    $dkim_signing_keys_by_domain{$domain} = []
      if !$dkim_signing_keys_by_domain{$domain};
  }
  my($any_wild); my($j) = 0;
  for my $ent (@dkim_signing_keys_list) {
    $ent->{v} = 'DKIM1'  if !defined $ent->{v};  # provide a default
    if (defined $ent->{n}) {  # encode n as qp-section (rfc4871, rfc2047)
      $ent->{n} =~ s{([\000-\037\177=;"])}{sprintf('=%02X',ord($1))}egs;
    }
    my($domain) = $ent->{domain};
    if (ref($domain) eq 'Regexp') {
      $ent->{domain_re} = $domain;
      $any_wild = sprintf("key#%d, %s", $j+1, $domain)  if !defined $any_wild;
    } elsif ($domain =~ /\*/) {
      # wildcarded signing domain in a key declaration, evil, asks for trouble!
      # support wildcards in signing domain for compatibility with dkim_milter
      my($regexp) = $domain;
      $regexp =~ s/\*{2,}/*/gs;   # collapse successive wildcards
      # '*' is a wildcard, quote the rest
      $regexp =~ s{ ([@#/.^$|*+?(){}\[\]\\]) }{$1 eq '*' ? '.*' : '\\'.$1}gex;
      $regexp = '^' . $regexp . '\\z';  # implicit anchors
      $regexp =~ s/^\^\.\*//s;    # remove leading anchor if redundant
      $regexp =~ s/\.\*\\z\z//s;  # remove trailing anchor if redundant
      $regexp = '(?:)'  if $regexp eq '';  # just in case, non-empty regexp
      # presence of {'domain_re'} entry lets get_dkim_key use this regexp
      # instead of a direct string comparision with {'domain'}
      $ent->{domain_re} = qr{$regexp};  # compiled regexp object
      $any_wild = sprintf("key#%d, %s", $j+1, $domain)  if !defined $any_wild;
    }
    # %dkim_signing_keys_by_domain entries contain lists of indices into
    # the @dkim_signing_keys_list of all potentially applicable signing keys.
    # This hash (keyed by domain name) avoids linear searching for signing
    # keys for all fully-specified domains in @dkim_signing_keys_list.
    # Wildcarded entries must still be looked up sequentially at run-time
    # to preserve the declared order and the 'first match wins' paradigm.
    # Such entries are only supported for compatibility with dkim_milter
    # and are evil because amavisd has no quick way of verifying that DNS RR
    # really exists, so signatures generated by amavisd can fail when not all
    # possible DNS resource records exist for wildcarded signing domains.
    #
    if (!defined($ent->{domain_re})) { # no regexp, just plain match on domain
      push(@{$dkim_signing_keys_by_domain{$domain}}, $j);
    } else {  # a wildcard in a signing domain, compatibility with dkim_milter
      # wildcarded signing domain potentially matches any _by_domain entry
      for my $d (keys %dkim_signing_keys_by_domain) {
        push(@{$dkim_signing_keys_by_domain{$d}}, $j);
      }
      # the '*' entry collects only wildcarded signing keys
      $dkim_signing_keys_by_domain{'*'} = []
        if !$dkim_signing_keys_by_domain{'*'};
      push(@{$dkim_signing_keys_by_domain{'*'}}, $j);
    }
    $j++;
  }
  do_log(0,"dkim: wildcard in signing domain (%s), may produce unverifiable ".
           "signatures with no published public key, avoid!", $any_wild)
        if $any_wild;
}

# THE get_dkim_key IS A DIRECT COPY OF THE SAME ROUTINE FROM amavisd
#
# Fetch a private DKIM signing key for a given signing domain, with its
# resource-record (RR) constraints compatible with proposed signature options.
# The first such key is returned as a hash; if no key is found an empty hash
# is returned. When a selector (s) is given it must match the selector of
# a key; when algorithm (a) is given, the key type and a hash algorithm must
# match the desired use too; the service type (s) must be 'email' or '*';
# when identity (i) is given it must match the granularity (g) of a key;
#
# sign.opts.     key options
# ----------     -----------
#  d         =>  domain
#  s         =>  selector
#  a         =>  k, h(list)
#  i         =>  g, t=s
#
sub get_dkim_key(@) {
  @_ % 2 == 0 or die "get_dkim_key: a list of pairs is expected as query opts";
  my(%options) = @_;  # signature options (v, a, c, d, h, i, l, q, s, t, x, z),
    # of which d is required, while s, a and t are optional but taken into
    # account in searching for a compatible key - the rest are ignored
  my(%key_options);
  my($domain) = $options{d};
  defined $domain && $domain ne ''
    or die "get_dkim_key: domain is required, but tag 'd' is missing";
  $domain = lc($domain);
  my(@indices) = $dkim_signing_keys_by_domain{$domain} ?
                   @{$dkim_signing_keys_by_domain{$domain}} :
                 $dkim_signing_keys_by_domain{'*'} ?
                   @{$dkim_signing_keys_by_domain{'*'}} : ();
  if (@indices) {
    my($selector) = $options{s};
    $selector = $selector eq '' ? undef : lc($selector)  if defined $selector;
    local($1,$2);
    my($keytype,$hashalg) =
      defined $options{a} && $options{a} =~ /^([a-z0-9]+)-(.*)\z/is ? ($1,$2)
                                                              : ('rsa',undef);
    my($identity_localpart,$identity_domain) =
      !defined($options{i}) ? () : split_address($options{i});
    $identity_localpart = ''  if !defined $identity_localpart;
    $identity_domain    = ''  if !defined $identity_domain;
    # find the first key (associated with a domain) with compatible options
    for my $j (@indices) {
      my($ent) = $dkim_signing_keys_list[$j];
      next unless defined $ent->{domain_re} ? $domain =~ $ent->{domain_re}
                                            : $domain eq $ent->{domain};
      next if defined $selector && $ent->{selector} ne $selector;
      next if $keytype ne (exists $ent->{k} ? $ent->{k} : 'rsa');
      next if exists $ent->{s} &&
              !(grep { $_ eq '*' || $_ eq 'email' } split(/:/, $ent->{s}) );
      next if defined $hashalg && exists $ent->{'h'} &&
              !(grep { $_ eq $hashalg } split(/:/, $ent->{'h'}) );
      if (defined($options{i})) {
        if (lc($identity_domain) eq $domain) {
          # ok
        } elsif (exists $ent->{t} && (grep {$_ eq 's'} split(/:/,$ent->{t}))) {
          next;  # no subdomains allowed
        }
        if (!exists($ent->{g}) || $ent->{g} eq '*') {
          # ok
        } elsif ($ent->{g} =~ /^ ([^*]*) \* (.*) \z/xs) {
          next if $identity_localpart !~ /^ \Q$1\E .* \Q$2\E \z/xs;
        } else {
          next if $identity_localpart ne $ent->{g};
        }
      }
      %key_options = %$ent;  last;  # found a suitable match
    }
  }
  if (defined $key_options{key_storage_ind}) {
    # obtain actual key from @dkim_signing_keys_storage
    ($key_options{key}) =
      @{$dkim_signing_keys_storage[$key_options{key_storage_ind}]};
  }
  %key_options;
}

sub proto_encode($@) {
  my($attribute_name,@strings) = @_; local($1);
  for ($attribute_name,@strings) {
    # just in case, handle non-octet characters:
    s/([^\000-\377])/sprintf('\\x{%04x}',ord($1))/eg and
      do_log(-1,"proto_encode: non-octet character encountered: %s", $_);
  }
  $attribute_name =~    # encode all but alfanumerics, . _ + -
    s/([^0-9a-zA-Z._+-])/sprintf("%%%02x",ord($1))/eg;
  for (@strings) {      # encode % and nonprintables
    s/([^\041-\044\046-\176])/sprintf("%%%02x",ord($1))/eg;
  }
  $attribute_name . '=' . join(' ',@strings);
}

sub proto_decode($) {
  my($str) = @_; local($1);
  $str =~ s/%([0-9a-fA-F]{2})/pack("C",hex($1))/egs;
  $str;
}

sub split_localpart($$) {
  my($localpart, $delimiter) = @_;
  my($owner_request_special) = 1;  # configurable ???
  my($extension); local($1,$2);
  if ($localpart =~ /^(postmaster|mailer-daemon|double-bounce)\z/i) {
    # do not split these, regardless of what the delimiter is
  } elsif ($delimiter eq '-' && $owner_request_special &&
           $localpart =~ /^owner-.|.-request\z/si) {
    # don't split owner-foo or foo-request
  } elsif ($localpart =~ /^(.+?)(\Q$delimiter\E.*)\z/s) {
    ($localpart, $extension) = ($1, $2);  # extension includes a delimiter
    # do not split the address if the result would have a null localpart
  }
  ($localpart, $extension);
}

sub unique_ref(@) {
  my($r) = @_ == 1 && ref($_[0]) ? $_[0] : \@_;  # accept list, or a list ref
  my(%seen);  my(@result) = grep { defined($_) && !$seen{$_}++ } @$r;
  \@result;
}

sub make_query_keys($$$;$) {
  my($addr,$at_with_user,$include_bare_user,$append_string) = @_;
  my($localpart,$domain) = split_address($addr); $domain = lc($domain);
  my($saved_full_localpart) = $localpart;
  $localpart = lc($localpart);  ### if !c('localpart_is_case_sensitive');
  # chop off leading @, and trailing dots
  local($1);
  $domain = $1  if $domain =~ /^\@?(.*?)\.*\z/s;
  my($extension); my($delim) = '+';  ### c('recipient_delimiter');
  if ($delim ne '') {
    ($localpart,$extension) = split_localpart($localpart,$delim);
    # extension includes a delimiter since amavisd-new-2.5.0!
  }
  $extension = ''  if !defined $extension;  # mute warnings
  my($append_to_user,$prepend_to_domain) = $at_with_user ? ('@','') : ('','@');
  my(@keys);  # a list of query keys
  push(@keys, $addr);                        # as is
  push(@keys, $localpart.$extension.'@'.$domain)
    if $extension ne '';                     # user+foo@example.com
  push(@keys, $localpart.'@'.$domain);       # user@example.com
  if ($include_bare_user) {  # typically enabled for local users only
    push(@keys, $localpart.$extension.$append_to_user)
      if $extension ne '';                   # user+foo(@)
    push(@keys, $localpart.$append_to_user); # user(@)
  }
  push(@keys, $prepend_to_domain.$domain);   # (@)sub.example.com
  if ($domain =~ /\[/) {     # don't split address literals
    push(@keys, $prepend_to_domain.'.');     # (@).
  } else {
    my(@dkeys); my($d) = $domain;
    for (;;) {               # (@).sub.example.com (@).example.com (@).com (@).
      push(@dkeys, $prepend_to_domain.'.'.$d);
      last  if $d eq '';
      $d = ($d =~ /^([^.]*)\.(.*)\z/s) ? $2 : '';
    }
    if (@dkeys > 10) { @dkeys = @dkeys[$#dkeys-9 .. $#dkeys] }  # sanity limit
    push(@keys,@dkeys);
  }
  if (defined $append_string && $append_string ne '') {
    $_ .= $append_string  for @keys;
  }
  my($keys_ref) = unique_ref(\@keys);  # remove duplicates
  ll(5) && do_log(5,"query_keys: %s", join(', ',@$keys_ref));
  # the rhs replacement strings are similar to what would be obtained
  # by lookup_re() given the following regular expression:
  # /^( ( ( [^\@]*? ) ( \Q$delim\E [^\@]* )? ) (?: \@ (.*) ) )$/xs
  my($rhs) = [   # a list of right-hand side replacement strings
    $addr,                  # $1 = User+Foo@Sub.Example.COM
    $saved_full_localpart,  # $2 = User+Foo
    $localpart,             # $3 = user
    $extension,             # $4 = +foo
    $domain,                # $5 = sub.example.com
  ];
  ($keys_ref, $rhs);
}

sub lookup_hash($$;$%) {
  my($addr, $hash_ref,$get_all,%options) = @_;
  ref($hash_ref) eq 'HASH'
    or die "lookup_hash: arg2 must be a hash ref: $hash_ref";
  local($1,$2,$3,$4); my(@matchingkey,@result); my($append_string);
  $append_string = $options{AppendStr}  if defined $options{AppendStr};
  my($keys_ref,$rhs_ref) = make_query_keys($addr,1,1,$append_string);
  for my $key (@$keys_ref) {   # do the search
    if (exists $$hash_ref{$key}) {  # got it
      push(@result,$$hash_ref{$key}); push(@matchingkey,$key);
      last  if !$get_all;
    }
  }
  # do the right-hand side replacements if any $n, ${n} or $(n) is specified
  for my $r (@result) {  # remember that $r is just an alias to array elements
    if (defined($r) && !ref($r) && index($r,'$') >= 0) { # plain string with $
      my($any) = $r =~ s{ \$ ( (\d+) | \{ (\d+) \} | \( (\d+) \) ) }
                        { my($j)=$2+$3+$4; $j<1 ? '' : $rhs_ref->[$j-1] }gxse;
      # bring taintedness of input to the result
      $r .= substr($addr,0,0)  if $any;
    }
  }
  if (!$get_all) { ($result[0], $matchingkey[0]) }
  else           { (\@result,   \@matchingkey)   }
}

sub lookup2($$$%) {
  my($get_all, $addr, $tables_ref, %options) = @_;
  (@_ - 3) % 2 == 0 or die "lookup2: options argument not in pairs (not hash)";
  my($label, @result,@matchingkey);
  for my $tb (!$tables_ref ? () : @$tables_ref) {
    my($t) = ref($tb) eq 'REF' ? $$tb : $tb; # allow one level of indirection
    if (!ref($t) || ref($t) eq 'SCALAR') {   # a scalar always matches
      my($r) = ref($t) ? $$t : $t;  # allow direct or indirect reference
      if (defined $r) {
        do_log(5,'lookup: (scalar) matches, result="%s"', $r);
        push(@result,$r); push(@matchingkey,"(constant:$r)");
      }
    } elsif (ref($t) eq 'HASH') {
      my($r,$mk);
      ($r,$mk) = lookup_hash($addr,$t,$get_all,%options)  if %$t;
      if (!defined $r)  {}
      elsif (!$get_all) { push(@result,$r);  push(@matchingkey,$mk)  }
      elsif (@$r)       { push(@result,@$r); push(@matchingkey,@$mk) }
    } else {
      die "TROUBLE: lookup table not implemented for object: " . ref($t);
    }
    last  if @result && !$get_all;
  }
  if (!$get_all) { ($result[0], $matchingkey[0]) }
  else           { (\@result,   \@matchingkey)   }
}

sub parse_quoted_rfc2821($$) {
  my($addr,$unquote) = @_;
  # the angle-bracket stripping is not really a duty of this subroutine,
  # as it should have been already done elsewhere, but we allow it here anyway:
  $addr =~ s/^\s*<//s;  $addr =~ s/>\s*\z//s;  # tolerate unmatched angle brkts
  local($1,$2); my($source_route,$localpart,$domain) = ('','','');
  # RFC 2821: so-called "source route" MUST BE accepted,
  #           SHOULD NOT be generated, and SHOULD be ignored.
  #           Path = "<" [ A-d-l ":" ] Mailbox ">"
  #           A-d-l = At-domain *( "," A-d-l )
  #           At-domain = "@" domain
  if (index($addr,':') >= 0 &&  # triage before more testing for source route
      $addr =~ m{^ (       [ \t]* \@ (?: [0-9A-Za-z.!\#\$%&*/^{}=_+-]* |
                                   \[ (?: \\. | [^\]\\] ){0,999} \] ) [ \t]*
                     (?: , [ \t]* \@ (?: [0-9A-Za-z.!\#\$%&*/^{}=_+-]* |
                                   \[ (?: \\. | [^\]\\] ){0,999} \] ) [ \t]* )*
                     : [ \t]* ) (.*) \z }xs)
  { # NOTE: we are quite liberal on allowing whitespace around , and : here,
    # and liberal in allowed character set and syntax of domain names,
    # we mainly avoid stop-characters in the domain names of source route
    $source_route = $1; $addr = $2;
  }
  if ($addr =~ m{^ ( .*? )
                 ( \@ (?: [^\@\[\]]+ | \[ (?: \\. | [^\]\\] ){0,999} \]
                          | [^\@] )* )
                 \z}xs) {
    ($localpart,$domain) = ($1,$2);
  } else {
    ($localpart,$domain) = ($addr,'');
  }
  $localpart =~ s/ " | \\ (.) | \\ \z /$1/xsg  if $unquote; # undo quoted-pairs
  ($source_route, $localpart, $domain);
}

sub unquote_rfc2821_local($) {
  my($mailbox) = @_;
  my($source_route,$localpart,$domain) = parse_quoted_rfc2821($mailbox,1);
  # make address with '@' in the localpart but no domain (like <"aa@bb.com"> )
  # distinguishable from <aa@bb.com> by representing it as aa@bb.com@ in
  # unquoted form; (it still obeys all regular rules, it is not a dirty trick)
  $domain = '@'  if $domain eq '' && $localpart ne '' && $localpart =~ /\@/;
  $localpart . $domain;
}

#
# ======================================================================
# Code above is copied from amavisd; some day it should be factored out.
# Code from here on is specific to amavisd-signer.
# ======================================================================
#

# process a request to choose a signing key;
#
sub choose_key_request($) {
  my($attr) = @_;
  my(@results);
  my(%sig_options);  # signature options, and constraints for choosing a key
  my(%key_options);  # options associated with a signing key
  my(@tried_domains);  # used for logging a failure
  my($chosen_addr,$chosen_addr_src);
  my($cand) = $attr->{candidate};
  my(@candidates) = !defined $cand ? () : !ref $cand ? $cand : @$cand;
  my($sobm) = \@dkim_signature_options_bysender_maps;
  for my $pair (@candidates) {
    my($addr_src,$addr) = split(' ',$pair,2);
    $addr = unquote_rfc2821_local($addr);
    my($addr_localpart,$addr_domain) = split_address($addr);
    $addr_domain = lc($addr_domain);
    my($dkim_options_ref,$mk_ref) = lookup2(1,$addr,$sobm);
    $dkim_options_ref = []  if !defined $dkim_options_ref;  #***?
    # place catchall default(s) at the end of the list of options;
    push(@$dkim_options_ref, { c => 'relaxed/simple', a => 'rsa-sha256' });
    %sig_options = ();  # signature options:
                  # (v), a, (b), (bh), c, d, (h), i, (l), q, s, (t), x, (z)
    # traverse from specific to general, first match wins
    for my $opts_hash_ref (@$dkim_options_ref) {
      while (my($k,$v) = each(%$opts_hash_ref))
        { $sig_options{$k} = $v  if !exists($sig_options{$k}) }
    }
    # a default for a signing domain is a domain of each tried address
    if (!exists($sig_options{d}))
      { my($d) = $addr_domain; $d =~ s/^\@//; $sig_options{d} = $d }
    push(@tried_domains, $sig_options{d});
    ll(5) && do_log(5, "signature options for %s(%s): %s", $addr,$addr_src,
            join('; ', map { $_.'='.$sig_options{$_} } keys %sig_options));
    # find a private key associated with a signing domain and selector,
    # and meeting constraints
    %key_options = get_dkim_key(%sig_options)
      if defined $sig_options{d} && $sig_options{d} ne '';
    my($key) = $key_options{key};
    if (defined $key && $key ne '') {  # found; copy the key and its options
      $sig_options{key} = $key;  $sig_options{s} = $key_options{selector};
      $chosen_addr = $addr; $chosen_addr_src = $addr_src;
      last;
    }
  }
  # if any signature options were specified in the request and not overruled
  # by more specific ones here, copy them to the resulting set of sig options
  for my $opt (keys %$attr) {
    if ($opt =~ /^sig\.(.+)\z/) {
      $sig_options{$1} = $attr->{$opt}  if !exists($sig_options{$1});
    }
  }
  ll(5) && do_log(5, "sig options: %s",
             join('; ', map { $_.'='.$sig_options{$_} } keys %sig_options));
  my(%key_options);
  if (defined $sig_options{d} && $sig_options{d} ne '') {
    %key_options = get_dkim_key(%sig_options);
  }
  do_log(5, "key options: %s is %s",
            $_, $key_options{$_}) for keys %key_options;
  my($s) = $key_options{'selector'};
  my($d) = $key_options{'domain'};
  $sig_options{'s'} = $s;
  $sig_options{'d'} = $d;
  delete $sig_options{'key'};  # no use of key ref in the protocol
  for my $opt (sort keys %sig_options) {
    if (defined $sig_options{$opt}) {
      push(@results, proto_encode('sig.'.$opt, $sig_options{$opt}));
    }
  }
  # optional information if available: client may log it, or use for debugging
  if (defined $chosen_addr_src && defined $chosen_addr) {
    push(@results, proto_encode('chosen_candidate',
                                $chosen_addr_src, $chosen_addr));
  }
  \@results;
}

# sign a digest code using the specified algorithm and a private signing key
#
sub dkim_rsa_sign($$$) {
  my($digest,$alg_name,$key) = @_;
  my($result);
  $digest = ''   if !defined $digest;
  $alg_name = '' if !defined $alg_name;
  if (defined $key && $key ne '') {
    my($key) = Mail::DKIM::PrivateKey->load(Cork => $key);
    $key  or die "no key available\n";
    $result = $key->sign_digest($alg_name,$digest);
  }
  $result;
}

# process a request to sign the supplied digest with a selected key
#
# presence of the 'b' attribute in the result indicates success,
# otherwise the result is treated as signature unavailable
#
sub sign_request($) {
  my($attr) = @_;
  my(@results, $reason, $sig);
  my($digest, $digest_alg, $selector, $domain) =
    @$attr{qw(digest digest_alg s d)};
  if (!defined $digest || $digest eq '') {
    $reason = 'cannot sign, digest not provided, nothing to sign';
  } elsif (!defined $digest_alg || $digest_alg eq '') {
    $reason = 'cannot sign, digest algorithm name not provided';
  } elsif (!defined $domain || $domain eq '') {
    $reason = 'cannot sign, signing domain not provided';
  } elsif (!defined $selector || $selector eq '') {
    $reason = 'cannot sign, selector not provided';
  } else {
    my(%sig_options);  # signature options: v, a, c, d, h, i, l, q, s, t, x, z
    $sig_options{s} = $selector;
    $sig_options{d} = $domain;
    my(%key_options) = get_dkim_key(%sig_options);
    if (!defined $key_options{key}) {
      $reason = 'cannot sign, signing key not available';
    } else {
      do_log(5, "key options: %s is %s",
                $_, $key_options{$_})  for keys %key_options;
      eval {
        $sig = dkim_rsa_sign(decode_base64($digest),
                             $digest_alg, $key_options{key});  1;
      } or do {
        my($eval_stat) = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
        do_log(0, "signing failed: %s", $eval_stat);
        $reason = 'cannot sign: ' . $eval_stat;
      };
      push(@results, proto_encode('d', $key_options{'domain'}));
      push(@results, proto_encode('s', $key_options{'selector'}));
    }
  }
  if (defined $sig && $sig ne '') {
    push(@results, proto_encode('b', encode_base64($sig,'')));
  } else {
    $reason = 'cannot sign: signing failed'  if !defined $reason;
    push(@results, proto_encode('reason', $reason));
  }
  \@results;
}

# process the request received from amavisd
#
sub do_the_request($) {
  my($attr) = @_;
  ll(2) && do_log(2, "got: %s", join('; ', map {
                      my($k) = $_; my($v) = $attr->{$k};
                      map { $k.'='.$_ } (!ref $v ? $v : @$v) } keys %$attr));
  my(@results);
  my($req_id) = $attr->{request_id};
  my($log_id) = $attr->{log_id};
  push(@results, proto_encode('request_id', $req_id))  if defined $req_id;
  push(@results, proto_encode('log_id',     $log_id))  if defined $log_id;
  my($request_type) = $attr->{request};
  $request_type = ''  if !defined $request_type;
  if ($request_type eq 'choose_key') {
    push(@results, @{choose_key_request($attr)});
  } elsif ($request_type eq 'sign') {
    push(@results, @{sign_request($attr)});
  } else {
    push(@results, proto_encode('reason', 'unknown request type'));
    do_log(2, "got: ignoring request: %s", $request_type);
  }
  ll(1) && do_log(1, "response: %s", join('; ', @results));
  do_log(5, "");
  \@results;
}

# IO::Multiplex -style callback hook
#
sub mux_connection {
  my($self,$mux,$fh) = @_;
  do_log(3, "client %s just connected", $self->{peeraddr});
  $self->{attr} = {};
}

# the mux_connection callback is guaranteed to have already been run once
#
sub mux_input {
  my($self,$mux,$fh,$in_ref) = @_;
  my $attr = $self->{attr};
  do_log(5, "input from %s ready", $self->{peeraddr});

  # process each line in the input, leaving partial lines in the input buffer
  local($1,$2); my($quit) = 0;
  while ($$in_ref =~ s/^(.*?)\015?\012//) {
    my($ln) = $1;
    if ($ln eq '') {  # empty line indicates end of a request
      my($results_ref) = do_the_request($attr);
      print(join('', map { $_."\015\012" } (@$results_ref,'')))
        or do_log(0,"mux_input: error writing a response to socket" );
      %$attr = ();  # reset, awaiting next request in the same session
    } elsif ($ln =~ /^ ([^=\000\012]*?) (?: = | : [ \t]* ) (.*) \z/xsi) {
      my($attr_name) = proto_decode($1);
      my($attr_val)  = proto_decode($2);
      if (!exists $attr->{$attr_name}) {
        $attr->{$attr_name} = $attr_val;  # simple scalar for one-time attrs
      } elsif (!ref($attr->{$attr_name})) {  # multiple, convert to a list
        $attr->{$attr_name} = [ $attr->{$attr_name}, $attr_val ];
      } else {  # append to a list of same-name attributes
        push(@{$attr->{$attr_name}}, $attr_val);
      }
    } else {
      do_log(0, "mux_input: ignored line: %s", $ln);
    }
  }
  close(STDOUT)  if $quit;
}


#
# Main program starts here (after initializations near the top of this file)
#

dkim_key_postprocess();

# set up a Net::Server configuration
$server = AmavisSigner->new({
  # limit socket bind (e.g. to the loopback interface)
  host => (!defined $inet_socket_bind || $inet_socket_bind eq '' ? '*'
                                                        : $inet_socket_bind),
  port => \@listen_sockets,  # listen on these sockets (Unix or inet)
  listen => $listen_queue_size,  # undef for a default
  user  => ($> == 0 || $< == 0) ? $daemon_user  : undef,
  group => ($> == 0 || $< == 0) ? $daemon_group : undef,
  background => $daemonize ? 1 : undef,
  setsid     => $daemonize ? 1 : undef,
  chroot     => $daemon_chroot_dir ne '' ? $daemon_chroot_dir : undef,
  pid_file   => $pid_file,
  log_file   => $daemonize ? 'Sys::Syslog' : undef,
  syslog_ident    => $syslog_ident,
  syslog_facility => $syslog_facility,
  syslog_logsock  => 'native',
  # 0=err, 1=warning, 2=notice, 3=info, 4=debug
  log_level => $log_level >= 5 ? 4 : 2,
});

$server->run;  # transferring control to Net::Server
exit 1;  # shouldn't get here

# TODO: pkcs11 URI
# In order to use a key an application needs the path to the PKCS11 lib,
# the key ID, username, pin and the slot number
#
# http://blogs.sun.com/janp/entry/pkcs_11_engine_patch_including
#   pkcs11:[object=<label>]  # object (key) label, eg. "mykey"
#   [;token=<label>]         # token label
#   [;manuf=<label>]         # manufacturer ID
#   [;serial=<label>]        # serial number of the token
#   [;model=<label>]         # token model
#   [;objecttype=(public|private|cert|data)]
#   [;passphrasedialog=(builtin|exec:<file>)]
#
# alternative:
#   pkcs11:///path/to/pkcs11/lib?slot=0&id=123
#   file:///path/to/pem/file
#
# SEE: http://blog.nominet.org.uk/tech/category/crypto/