spf-dkim-dmarc-demo/sender/web-api/lib/Email/SpoofingDemo/DKIM.pm

#
# SPDX-FileCopyrightText: 2023 Afnic
#
# SPDX-License-Identifier: GPL-3.0-or-later
#

package Email::SpoofingDemo::DKIM;

use strict;
use warnings;
use v5.10;
use utf8;

use Exporter 'import';

our @EXPORT_OK = qw(read_signing_table read_key_table
                    write_signing_table write_key_table
                    generate_dkim_key);

sub generate_dkim_key {
    my ($domain, $selector, $key_size, $key_table_name, $key_dir, $signing_table_name) = @_;

    die if $domain =~ /\.\./;

    my $key_domain_dir = "$key_dir/$domain";

    # Generate the key
    system("mkdir", "-p", $key_domain_dir);
    system("opendkim-genkey",
           "-D", $key_domain_dir,
           "-d", $domain,
           "-s", $selector,
           "-b", $key_size);
    system("chown", "-R", "opendkim", $key_domain_dir);

    # Read in the public key
    my $public_key_file = "$key_domain_dir/$selector.txt";
    open(my $fh, '<', $public_key_file) or die "$key_domain_dir: $!";
    my $data = eval {
        local $/ = undef;
        my $raw_record = <$fh>;
        my ($owner, $class, $type, $data) = split(" ", $raw_record, 4);
        $data =~ s/\s*;.*$//;
        return $data;
    };
    close($fh);

    # Update key table
    my $key_table = read_key_table($key_table_name);
    push @{$key_table->{$domain}}, $selector;
    write_key_table($key_table_name, $key_dir, $key_table);

    # Update signing table if it’s the first key for the domain
    my $signing_table = read_signing_table($signing_table_name);
    if (not exists $signing_table->{$domain}) {
        $signing_table->{$domain} = $selector;
        write_signing_table($signing_table_name, $signing_table);
    }

    # Done!
    reload_opendkim();

    return $data;
}

sub read_signing_table {
    my ($filename) = @_;

    my %sign_table;

    open(my $fh, '<', $filename) or die "$filename: $!";
    while (<$fh>) {
        chomp;
        s/#.*$//;
        next if /^\s*$/;

        my ($domain_or_email, $key_id) = split(" ", $_, 2);
        my $domain = ($domain_or_email =~ s/^.*@//r);
        my $selector = ($key_id =~ s/\._domainkey.$domain$//r);

        $sign_table{$domain} = $selector;
    }
    close($fh);

    return \%sign_table;
}

sub write_signing_table {
    my ($filename, $contents) = @_;

    open(my $fh, '>', $filename) or die "$filename: $!";
    binmode($fh, ':utf8');
    print $fh <<'EOF';
##
## FORMAT DE LA TABLE
##
## <domaine ou adresse mail>    <identifiant>
##
## L’adresse mail peut être un wildcard (ex. *@expediteur.example).
##

EOF
    for my $domain (sort keys %$contents) {
        my $selector = $contents->{$domain};
        my $key_id = "$selector._domainkey.$domain";
        printf $fh "%-30s %s\n", $domain, $key_id;
    }
    close($fh);
}

sub read_key_table {
    my ($filename) = @_;

    # We only care about the list of keys that exist for a given domain.
    # The rest of the data can be deduced from that mapping.

    my %key_table;

    open(my $fh, '<', $filename) or die "$filename: $!\n";
    while (<$fh>) {
        chomp;
        s/#.*$//;
        next if /^\s*$/;

        my ($key_id, $key_spec) = split(" ", $_, 2);
        my ($domain, $selector, $key_location) = split(":", $key_spec, 3);

        push @{$key_table{$domain}}, $selector;
    }

    return \%key_table;
}

sub write_key_table {
    my ($filename, $key_dir, $contents) = @_;

    open(my $fh, '>', $filename) or die "$filename: $!\n";
    binmode($fh, ':utf8');
    print $fh <<EOF;
##
## FORMAT DE LA TABLE
##
## <identifiant>       <domaine>:<sélecteur>:<fichier>
##

EOF
    for my $domain (sort keys %$contents) {
        for my $selector (@{$contents->{$domain}}) {
            my $key_id = "$selector._domainkey.$domain";
            my $key_file = "$key_dir/$domain/$selector.private";

            printf $fh "%-30s %s:%s:%s\n", $key_id, $domain, $selector, $key_file;
        }
    }
    close($fh);
}

sub reload_opendkim {
    system(qw(killall -USR1 opendkim));
    return (($? >> 8) == 0);
}

1;