# SPDX-License-Identifier: GPL-2.0-or-later

package Amavis::Tools;
use strict;
use re 'taint';
use warnings;
use warnings FATAL => qw(utf8 void);
no warnings 'uninitialized';
# use warnings 'extra'; no warnings 'experimental::re_strict'; use re 'strict';

BEGIN {
  require Exporter;
  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);
  $VERSION = '2.412';
  @ISA = qw(Exporter);
  @EXPORT_OK = qw(&show_or_test_dkim_public_keys &generate_dkim_private_key
                  &convert_dkim_keys_file);
}
use subs @EXPORT_OK;

use Errno qw(ENOENT EACCES);
use IO::File qw(O_RDONLY O_WRONLY O_RDWR O_APPEND O_CREAT O_EXCL);
use Crypt::OpenSSL::RSA ();

use Amavis::Conf qw(:platform c cr ca
                     @dkim_signing_keys_list @dkim_signing_keys_storage);
use Amavis::rfc2821_2822_Tools qw(rfc2822_timestamp);
use Amavis::Util qw(untaint ll do_log
                    safe_encode_utf8_inplace idn_to_ascii idn_to_utf8);

# Prints DNS TXT resource records for corresponding DKIM private keys (as
# previously declared by calls to dkim_key) in a format directly suitable
# for inclusion in DNS zone files. If an argument is provided the result is
# restricted to listed domains only, otherwise RR for all domains are shown.
# Note that a domain may have more than one RR: one RR for each selector.
#
# When a search argument is provided (even if '.'), the printed list is
# sorted according to reversed domain labels (e.g. com.example.sub.host),
# entries with the same domain are kept in original order. When there are
# no search arguments, the original order is retained.
#
sub show_or_test_dkim_public_keys($$) {
  my($cmd,$args) = @_;
  # when list is empty all domains are implied
  my(@seek_domains) = map(idn_to_ascii($_), @$args);
  my(@sort_list) = map { my $d = lc($dkim_signing_keys_list[$_]->{domain});
                         my $d_re = $dkim_signing_keys_list[$_]->{domain_re};
                         [$_, $d, $d_re, join('.',reverse split(/\./,$d,-1))] }
                       0 .. $#dkim_signing_keys_list;
  if (@seek_domains) {  # sort only when there are any search arguments present
    @sort_list = sort {$a->[3] cmp $b->[3] || $a->[0] <=> $b->[0]} @sort_list;
  }
  my $any = 0;
  for my $e (@sort_list) {
    my($j,$domain,$domain_re) = @$e;  local($1);
    safe_encode_utf8_inplace($domain);  # to octets (if not already)
    my $domain_ace = idn_to_ascii($domain);
    next  if @seek_domains &&
             !grep { defined $domain_re ? lc($_) =~ /$domain_re/
                     : /^\.(.*)\z/s ?
                       $domain_ace eq lc($1) ||
                         $domain_ace =~ /(?:\.|\z)\Q$1\E\z/si
                     : $domain_ace eq lc($_) } @seek_domains;
    $any++;
    my $key_opts = $dkim_signing_keys_list[$j];
    if ($cmd eq 'testkeys' || $cmd eq 'testkey') {
      test_dkim_key(%$key_opts);
    } else {
      my $selector = $key_opts->{selector};
      safe_encode_utf8_inplace($selector);  # to octets (if not already)
      my $selector_ace = idn_to_ascii($selector);
      my $key_storage_ind = $key_opts->{key_storage_ind};
      my($key,$dev,$inode,$fname) =
        @{ $dkim_signing_keys_storage[$key_storage_ind] };
      my(@pub) = split(/\r?\n/, $key->get_public_key_x509_string);
      @pub = grep(!/^---.*?---\z/ && !/^[ \t]*\z/, @pub);
      my(@tags) = map($_.'='.$key_opts->{$_},
                      grep(defined $key_opts->{$_}, qw(v g h k s t n)));
      my $key_size = 8 * $key->size;
      printf("; key#%d %d bits, s=%s, d=%s%s\n",
             $key_opts->{key_ind} + 1, $key_size,
             $selector, $domain,
             defined $fname ? ', '.$fname : '');
      printf("; CANNOT DECLARE A WILDCARDED LABEL IN DNS, ".
             "AVOID OR EDIT MANUALLY!\n")  if defined $key_opts->{domain_re};
      printf("%s._domainkey.%s.\t%s TXT (%s)\n\n",
             $selector_ace, $domain_ace, '3600',
             join('', map("\n" . '  "' . $_ . '"',
                          join('; ',@tags,'p='), @pub)) );
    }
  }
  if (!@dkim_signing_keys_list) {
    printf("No DKIM private keys declared in a config file.\n");
  } elsif (!$any) {
    printf("No DKIM private keys match the selection list.\n");
  }
}

sub test_dkim_key(@) {
  my(%key_options) = @_;
  my $now = Time::HiRes::time;
  my $key_storage_ind = $key_options{key_storage_ind};
  my($key,$dev,$inode,$fname) =
    @{ $dkim_signing_keys_storage[$key_storage_ind] };
  if (UNIVERSAL::isa($key,'Crypt::OpenSSL::RSA')) {
    $key = Mail::DKIM::PrivateKey->load(Cork => $key);  # avail since 0.31
    # my $pkcs1 = $key->get_private_key_string;  # most compact
    # $pkcs1 =~ s/^---.*?---(?:\r?\n|\z)//gm;  $pkcs1 =~ tr/\r\n//d;
    # $key = Mail::DKIM::PrivateKey->load(Data => $pkcs1);
  }
  my $domain = idn_to_utf8($key_options{domain});
  my $domain_ace = idn_to_ascii($domain);
  my $selector_ace = idn_to_ascii($key_options{selector});
  my $policyfn = sub {
    my $dkim = $_[0];
    $dkim->add_signature( Mail::DKIM::Signature->new(
      Selector => $selector_ace, Domain => $domain_ace,
      Method => 'simple/simple', Algorithm => 'rsa-sha256',
      Timestamp => int($now), Expiration => int($now)+24*3600, Key => $key,
    )); undef;
  };
  my $msg = sprintf(
    "From: test\@%s\nMessage-ID: <123\@%s>\nDate: %s\nSubject: test\n\ntest\n",
    $domain, $domain, rfc2822_timestamp($now));
  $msg =~ s{\n}{\015\012}gs;
  my(@gen_signatures, @read_signatures);
  eval {
    my $dkim_signer = Mail::DKIM::Signer->new(Policy => $policyfn);
    $dkim_signer or die "Could not create a Mail::DKIM::Signer object";
    $dkim_signer->PRINT($msg) or die "Can't write to dkim: $!";
    $dkim_signer->CLOSE or die "Can't close dkim signer: $!";
    @gen_signatures = $dkim_signer->signatures;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    print STDERR "dkim signing failed: $eval_stat\n";
  };
  $msg = $_->as_string . "\015\012" . $msg  for @gen_signatures;
  eval {
    my $dkim_verifier = Mail::DKIM::Verifier->new;
    $dkim_verifier or die "Could not create a Mail::DKIM::Verifier object";
    $dkim_verifier->PRINT($msg) or die "Can't write to dkim: $!";
    $dkim_verifier->CLOSE or die "Can't close dkim_verifier: $!";
    @read_signatures = $dkim_verifier->signatures;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    print STDERR "dkim verification failed: $eval_stat\n";
  };
# printf("%s\n", $fname)  if defined $fname;
  printf("TESTING#%d %s: %s => %s\n",
         $key_options{key_ind} + 1, $domain,
         $_->selector . '._domainkey.' . $_->domain,
         $_->result_detail)  for @read_signatures;
}

sub generate_dkim_private_key(@) {
  my($fname,$nbits) = @_;
  my $fh;
  eval {
    $nbits = 1024  if !defined($nbits) || $nbits eq '';
    $nbits =~ /^\d+\z/  or die "Number of bits in a key must be numeric\n";
    $nbits >= 512
      or die "Number of bits is below 512 (suggested 1024..2048)\n";
    $nbits <= 4096
      or die "Number of bits too large (suggested 1024..2048)\n";
    defined $fname && $fname ne ''
      or die "File name for a key not provided\n";
    $nbits >= 1024
      or printf STDERR ("INFO: RFC 6376 states: Signers MUST use RSA keys ".
                        "of at least 1024 bits for long-lived keys.\n");
    $fh = IO::File->new;
    $fh->open(untaint($fname), O_CREAT|O_EXCL|O_RDWR, 0600)
      or die "Can't create file \"$fname\": $!\n";
    my $rsa = Crypt::OpenSSL::RSA->generate_key($nbits);
    $fh->print($rsa->get_private_key_string)
      or die "Error writing key to a file \"$fname\": $!\n";
    $fh->close or die "Can't close file \"$fname\": $!\n";
    undef $fh;
    printf STDERR ("Private RSA key successfully written to file \"%s\" ".
                   "(%d bits, PEM format) \n", $fname,$nbits);
    1;
  } or do {
    my $eval_stat = $@ ne '' ? $@ : "errno=$!";  chomp $eval_stat;
    $fh->close  if defined $fh;  # ignoring status
    die "genrsa: $eval_stat\n";
  }
}

# Reads a dkim-filter -compatible key specifications. From the dkim-filter
# man page: The keyfile should contain a set of lines of the form
# sender-pattern:signing-domain:keypath where sender-pattern is a pattern
# to match against message senders (with a special character "*" interpreted
# as "zero or more characters"), signing-domain is the domain to announce as
# the signing domain when generating signatures (or a '*', implying author's
# domain), and keypath is a path to the PEM-formatted private key to be used
# for signing messages which match the sender-pattern. The selector used in
# the signature will be the filename portion of keypath. A line starting
# with "/" is interpreted as a root directory for keys, meaning the keypath
# values after that line in the file are taken relative to that path. If a
# file referenced by keypath cannot be opened, the filter will try again by
# appending ".pem" and then ".private".  '#'-delimited comments and blank
# lines are ignored.
#
sub convert_dkim_keys_file($) {
  my $keysfile = $_[0];
  my $inp = IO::File->new;
  $inp->open($keysfile,'<')
    or die "dkim_key_file: Can't open file $keysfile for reading: $!";
  my($basedir,@options,@opt_re,%domain_selectors); my $rn = 0; my $ln;
  for ($! = 0; defined($ln=$inp->getline); $! = 0) {
    chomp($ln); $rn++; local($1); my($selector,$key_fn);
    if ($ln =~ /^ \s* (?: \# | \z)/xs) {
      # skip empty and all-comment lines
    } elsif ($ln =~ m{^/}) {
      $basedir = $ln;  $basedir .= '/' if $basedir !~ m{/\z};
    } else {
      my($sender_pattern, $signing_domain, $keypath) =
        map { my $s = $_; $s =~ s/^\s+//; $s =~ s/\s+\z//; $s }
            split(/:/, $ln, 3);
      defined $sender_pattern && $sender_pattern ne ''
        or die "Error in $keysfile, empty sender pattern, line $rn: $ln\n";
      defined $keypath && $keypath ne ''  ||  $signing_domain eq ''
        or die "Error in $keysfile, empty file name field, line $rn: $ln\n";
      $keypath = $basedir . $keypath  if defined $basedir && $keypath !~ m{^/};
      for my $ext ('', '.pem', '.private') {
        my $errn = stat($keypath.$ext) ? 0 : 0+$!;
        if ($errn != ENOENT) { $key_fn = $keypath.$ext; last }
      }
      defined $key_fn
        or die "File $keypath does not exist, $keysfile line $rn: $ln\n";
      $selector = lc($1)  if $keypath =~ m{ (?: ^ | / ) ( [^/]+? )
                                            (?: \.pem | \.private )? \z }xs;
      # must convert sender pattern to unquoted form to match actual addresses
      my $sender_domain;
      if ($sender_pattern eq '*' || $sender_pattern eq '*@*') {
        $sender_pattern = $sender_domain = '*';
      } else {
        my $sender_localpart;
        ($sender_localpart, $sender_domain) =
          Amavis::rfc2821_2822_Tools::split_address(
           Amavis::rfc2821_2822_Tools::unquote_rfc2821_local($sender_pattern));
        $sender_domain =~ s/^\@//;
        $sender_pattern = $sender_localpart.'@'.idn_to_ascii($sender_domain);
      }
      if ($signing_domain eq '*') { $signing_domain = $sender_domain }
      $signing_domain = idn_to_ascii($signing_domain);
      if ($signing_domain ne '' &&
          !$domain_selectors{$signing_domain}{$selector}) {
      # dkim_key($signing_domain,$selector,$key_fn);  # declare a signing key
        printf("dkim_key(%-18s %-12s '%s');\n",
               "'".$signing_domain."',", "'".$selector."',", $key_fn);
        $domain_selectors{$signing_domain}{$selector} = 1;
      }
      if ($signing_domain eq $sender_domain) { $signing_domain = '*' }
      push(@options, [$sender_pattern, $signing_domain, $selector]);
    }
  }
  defined $ln || $! == 0  or die "Error reading from $keysfile: $!";
  $inp->close or die "Error closing $keysfile: $!";
  #
  # prepare by_sender signature options lookup table when non-default
  # signing is required (e.g. third-party signatures)
  #
  my $in_options = 0;
  for my $opt (@options) {
    my($sender_pattern, $signing_domain, $selector) = @$opt;
    if ($signing_domain eq '*') {
      # implies author domain signature, no need for special options
    } else {
      $sender_pattern =~ s/\*{2,}/*/gs;   # collapse successive wildcards
      $sender_pattern =~  # '*' is a wildcard, quote the rest
        s{ ([@\#/.^\$|*+?(){}\[\]\\]) }{ $1 eq '*' ? '.*' : '\\'.$1 }xgse;
      $sender_pattern = '^' . $sender_pattern . '\\z';  # implicit anchors
      # remove trailing first, leading next, preferring /^.*\z/ -> /^/, not /\z/
      $sender_pattern =~ s/\.\*\\z\z//s;  # remove trailing anchor if redundant
      $sender_pattern =~ s/^\^\.\*//s;    # remove leading anchor if redundant
      $sender_pattern = '(?:)'  if $sender_pattern eq '';  # just in case
      $signing_domain = undef if $signing_domain eq '';
      $selector = undef       if $selector       eq '';
      # case insensitive matching for compatibility with dkim-milter
      push(@opt_re, [ qr/$sender_pattern/is =>
                        ( !defined($signing_domain) ||
                          keys(%{$domain_selectors{$signing_domain}})==1
                          ? { d => $signing_domain }
                          : { d => $signing_domain, s => $selector } ) ]);
      if (!$in_options) {
        printf("\n%s\n", '@dkim_signature_options_bysender_maps = (new_RE(');
        $in_options = 1;
      }
      printf("  [ %-30s => { d=>%s%s} ],\n",
           'qr/' . $sender_pattern . '/is',
           !defined($signing_domain) ? 'undef' : "'".$signing_domain."'",
           !defined($signing_domain) ||
           keys %{$domain_selectors{$signing_domain}} == 1 ? ''
             : !defined($selector) ? ', s=>undef' : ", s=>'".$selector."'");
    }
  }
  printf("%s\n", '));')  if $in_options;
# use Devel::Peek qw(Dump);
# use Data::Dump (); Data::Dump::dump(@opt_re);
# unshift(@dkim_signature_options_bysender_maps,
#         Amavis::Lookup::RE->new(@opt_re))  if @opt_re;
}

1;