#!/usr/bin/perl -w
#
# Standalone DKIM2 signer CLI (draft-ietf-dkim-dkim2-spec-06).
#
# Reads a message, computes a Message-Instance when the content has changed
# since the top instance, signs, and writes the result to stdout. The
# counterpart of dkim2verify, and of python/dkim2sign.py and c/dkim2sign, so a
# cross-implementation harness can treat them all the same way.
#
#   dkim2sign -s SELECTOR -d DOMAIN -k KEYFILE [--mailfrom '<a@b>']
#                [--rcptto '<c@d>']... [--timestamp N] [--next-domain D]
#                [--flag F]... [--allow-null-body-recipe]
#                [--ignore-timestamps] [--dns-json PATH] [MESSAGE|-]
#
# Before extending an existing DKIM2 chain it runs the same verify-before-sign
# gate as dkim2-milter (Mail::DKIM2::Gate): the upstream signatures must
# verify, the Message-Instance chain must undo cleanly, and a null body Recipe
# on an UNSIGNED Message-Instance (m= above every signature's m=, top or not)
# is refused unless --allow-null-body-recipe; a null an upstream domain
# already signed is extended without it. A top signature carrying
# nd= is extended only when nd= equals DOMAIN. On refusal it prints the reason
# on stderr and exits 1 with nothing on stdout.
#
# Per §9.1/§9.2.5 an unmodified hop adds no Message-Instance: if the top
# instance already matches the content, its m= is reused and only a
# DKIM2-Signature is added.

use 5.020;
use strict;
use warnings;
use Email::MIME;
use Getopt::Long qw(GetOptions);
use FindBin;
use lib -d "$FindBin::Bin/../lib/Mail/DKIM2" ? "$FindBin::Bin/../lib" : ();   # running from a checkout

use Mail::DKIM2::Common qw(fold_header parse_dkim_pubkey parse_mime);
use Mail::DKIM2::Gate;
use Mail::DKIM2::MessageInstance;
use Mail::DKIM2::Signer;

my ($selector, $domain, $keyfile, $timestamp, $next_domain);
my $mailfrom = '<>';
my $hash_algs = 'sha256';
my (@rcptto, @flags);
my ($allow_null, $ignore_ts, $dns_json);
$dns_json = $ENV{DKIM2_DNS_JSON} if defined $ENV{DKIM2_DNS_JSON} && length $ENV{DKIM2_DNS_JSON};

GetOptions(
    's|selector=s'    => \$selector,
    'd|domain=s'      => \$domain,
    'k|keyfile=s'     => \$keyfile,
    'mailfrom=s'      => \$mailfrom,
    'rcptto=s'        => \@rcptto,
    'timestamp=i'     => \$timestamp,
    'next-domain=s'   => \$next_domain,
    'flag=s'          => \@flags,
    'hash=s'          => \$hash_algs,
    'allow-null-body-recipe' => \$allow_null,
    'ignore-timestamps'      => \$ignore_ts,
    'dns-json=s'      => \$dns_json,
) or die _usage();

die _usage() unless defined $selector && defined $domain && defined $keyfile;

# spec-06 §3.1: signer chooses one or both hash algorithms for the
# Message-Instance h= tag. Default MUST remain sha256 (byte-identical to
# pre-spec-06 output).
my %HASH_ALG_SETS = (
    sha256 => ['sha256'],
    sha512 => ['sha512'],
    both   => ['sha256', 'sha512'],
);
my $algs = $HASH_ALG_SETS{$hash_algs}
    or die _usage("invalid --hash value '$hash_algs' (expected sha256|sha512|both)");

my $file = shift // '-';
my $raw = $file eq '-'
    ? do { local $/; binmode STDIN; <STDIN> }
    : do { open my $fh, '<:raw', $file or die "$file: $!\n"; local $/; <$fh> };
die "empty message\n" unless defined $raw && length $raw;

# Normalise to CRLF: the hashes are defined over CRLF line endings.
$raw =~ s/\r\n/\n/g;
$raw =~ s/\r/\n/g;
$raw =~ s/\n/\r\n/g;

# Gate (shared with dkim2-milter, Mail::DKIM2::Gate): before extending an
# existing DKIM2 chain, verify it -- an unsigned top Message-Instance is the one
# we are about to cover, so it is allowed -- and refuse a null body Recipe on
# an unsigned instance unless --allow-null-body-recipe. A message with no
# chain is signed as before.
my %gate_opts = (AllowNullBodyRecipe => $allow_null, SkipTimestampCheck => $ignore_ts,
                 SigningDomain => $domain);
if ($dns_json) {
    require JSON;
    my $dns = do {
        open my $fh, '<', $dns_json or die "$dns_json: $!\n";
        local $/; JSON::decode_json(<$fh>);
    };
    $gate_opts{PubkeyCallback} = sub {
        my ($sig, $idx, $verifier) = @_;
        my ($sel, $dom) = ($sig->selector($idx // 0), $sig->domain);
        my $txt = $dns->{$dom}{"$sel._domainkey"}[0][1]
            if $dom && $sel && $dns->{$dom};
        return parse_dkim_pubkey($txt) if $txt;
        return $verifier->fetch_public_key($sig, $idx);
    };
}
my $gate = Mail::DKIM2::Gate->check($raw, %gate_opts);
unless ($gate->{ok}) {
    print STDERR "dkim2sign: not signing: $gate->{message}\n";
    exit 1;
}

my $msg = parse_mime($raw);

# §9.1/§9.2.5: only add an instance if this hop actually changed something.
# MessageInstance->verify returns the version it matched, so a true result means
# the top instance still describes the message and must be reused.
my $mi_header;
unless (Mail::DKIM2::MessageInstance->verify($msg)) {
    my $mi = Mail::DKIM2::MessageInstance->calculate($msg, undef, Algs => $algs);
    ($mi_header = fold_header('Message-Instance: ' . $mi->as_string))
        =~ s/^Message-Instance:\s*//;
    $msg->header_raw_prepend('Message-Instance', $mi_header);
}

my $signer = Mail::DKIM2::Signer->new(
    Selector => $selector,
    Domain   => $domain,
    KeyFile  => $keyfile,
    ($next_domain
        ? (NextDomain => $next_domain)
        : (MailFrom => $mailfrom, RcptTo => (@rcptto ? \@rcptto : ['<>']))),
    (defined $timestamp ? (Timestamp => $timestamp) : ()),
    (@flags ? (Flags => \@flags) : ()),
);
$signer->PRINT($msg->as_string);
$signer->CLOSE;

die "signing failed: " . ($signer->result_detail // 'no result') . "\n"
    unless ($signer->result // '') eq 'signed';

(my $sig_header = $signer->as_string) =~ s/^DKIM2-Signature:\s*//;
$msg->header_raw_prepend('DKIM2-Signature', $sig_header);

my $out = $msg->as_string;
$out =~ s/\r\n/\n/g;
$out =~ s/\n/\r\n/g;
binmode STDOUT;
print $out;

sub _usage {
    my ($err) = @_;
    my $usage = <<"USAGE";
usage: $0 -s SELECTOR -d DOMAIN -k KEYFILE [options] [MESSAGE|-]

  -s, --selector S   DKIM2 selector
  -d, --domain D     signing domain
  -k, --keyfile F    PEM private key
      --mailfrom A   MAIL FROM, bracketed (default <>)
      --rcptto A     RCPT TO, bracketed; repeatable
      --timestamp N  fixed t= (default: now)
      --next-domain D  emit nd= for an imaginary forwarding hop, omitting mf=/rt=
      --flag F       f= flag; repeatable
      --allow-null-body-recipe  sign even if a Message-Instance has a null body
                     Recipe that no upstream signature covers (its m= is above
                     every signature's m=; a signed null needs no option)
      --ignore-timestamps  do not fail an upstream signature for its t= age
      --dns-json PATH  answer key lookups from an interop dns.json (default \$DKIM2_DNS_JSON)
      --hash A       hash algorithm(s) for Message-Instance h=: sha256|sha512|both (default sha256)
USAGE
    return $err ? "$err\n$usage" : $usage;
}
