File Coverage

blib/lib/Mail/DKIM/Signer.pm

Criterion	Covered	Total	%
statement	149	172	86.6
branch	54	78	69.2
condition	13	28	46.4
subroutine	19	21	90.4
pod	10	15	66.6
total	245	314	78.0

package Mail::DKIM::Signer;
use strict;
use warnings;
our $VERSION = '1.20230212'; # VERSION
# ABSTRACT: generates a DKIM signature for a message

# Copyright 2005-2007 Messiah College. All rights reserved.
# Jason Long

# Copyright (c) 2004 Anthony D. Urso. All rights reserved.
# This program is free software; you can redistribute it and/or
# modify it under the same terms as Perl itself.

use Mail::DKIM::PrivateKey;
use Mail::DKIM::Signature;


use base 'Mail::DKIM::Common';
use Carp;

# PROPERTIES
#
# public:
#
# $dkim->{Algorithm}
#   identifies what algorithm to use when signing the message
#   default is "rsa-sha1"
#
# $dkim->{Domain}
#   identifies what domain the message is signed for
#
# $dkim->{KeyFile}
#   name of the file containing the private key used to sign
#
# $dkim->{Method}
#   identifies what canonicalization method to use when signing
#   the message. default is "relaxed"
#
# $dkim->{Policy}
#   a signing policy (of type Mail::DKIM::SigningPolicy)
#
# $dkim->{Selector}
#   identifies name of the selector identifying the key
#
# $dkim->{Key}
#   the loaded private key
#
# private:
#
# $dkim->{algorithms} = []
#   an array of algorithm objects... an algorithm object is created for
#   each signature being added to the message
#
# $dkim->{result}
#   result of the signing policy: "signed" or "skipped"
#
# $dkim->{signature}
#   the created signature (of type Mail::DKIM::Signature)

sub init {
    my $self = shift;
    $self->SUPER::init;

    if ( defined $self->{KeyFile} ) {
        $self->{Key} ||=
          Mail::DKIM::PrivateKey->load( File => $self->{KeyFile} );
    }

    unless ( $self->{'Algorithm'} ) {

        # use default algorithm
        $self->{'Algorithm'} = 'rsa-sha1';
    }
    unless ( $self->{'Method'} ) {

        # use default canonicalization method
        $self->{'Method'} = 'relaxed';
    }
    unless ( $self->{'Domain'} ) {

        # use default domain
        $self->{'Domain'} = 'example.org';
    }
    unless ( $self->{'Selector'} ) {

        # use default selector
        $self->{'Selector'} = 'unknown';
    }
}

sub finish_header {
    my $self = shift;

    $self->{algorithms} = [];

    my $policy = $self->{Policy};
    if ( UNIVERSAL::isa( $policy, 'CODE' ) ) {

        # policy is a subroutine ref
        my $default_sig = $policy->($self);
        unless ( @{ $self->{algorithms} } || $default_sig ) {
            $self->{'result'} = 'skipped';
            return;
        }
    }
    elsif ( $policy && $policy->can('apply') ) {

        # policy is a Perl object or class
        my $default_sig = $policy->apply($self);
        unless ( @{ $self->{algorithms} } || $default_sig ) {
            $self->{'result'} = 'skipped';
            return;
        }
    }

    unless ( @{ $self->{algorithms} } ) {

        # no algorithms were created yet, so construct a signature
        # using the current signature properties

        # check properties
        unless ( $self->{'Algorithm'} ) {
            die 'invalid algorithm property';
        }
        unless ( $self->{'Method'} ) {
            die 'invalid method property';
        }
        unless ( $self->{'Domain'} ) {
            die 'invalid header property';
        }
        unless ( $self->{'Selector'} ) {
            die 'invalid selector property';
        }

        $self->add_signature(
            Mail::DKIM::Signature->new(
                Algorithm => $self->{'Algorithm'},
                Method    => $self->{'Method'},
                Headers   => $self->headers,
                Domain    => $self->{'Domain'},
                Selector  => $self->{'Selector'},
                Key       => $self->{'Key'},
                KeyFile   => $self->{'KeyFile'},
                (
                    $self->{'Identity'} ? ( Identity => $self->{'Identity'} )
                    : ()
                ),
                (
                    $self->{'Timestamp'} ? ( Timestamp => $self->{'Timestamp'} )
                    : ()
                ),
                (
                    $self->{'Expiration'} ? ( Expiration => $self->{'Expiration'} )
                    : ()
                ),
            )
        );
    }

    foreach my $algorithm ( @{ $self->{algorithms} } ) {

        # output header as received so far into canonicalization
        foreach my $header ( @{ $self->{headers} } ) {
            $algorithm->add_header($header);
        }
        $algorithm->finish_header( Headers => $self->{headers} );
    }
}

sub finish_body {
    my $self = shift;

    foreach my $algorithm ( @{ $self->{algorithms} } ) {

        # finished canonicalizing
        $algorithm->finish_body;

        # load the private key file if necessary
        my $signature = $algorithm->signature;
        my $key =
             $signature->{Key}
          || $signature->{KeyFile}
          || $self->{Key}
          || $self->{KeyFile};
        if ( defined($key) && !ref($key) ) {
            $key = Mail::DKIM::PrivateKey->load( File => $key );
        }
        $key
          or die "no key available to sign with\n";

        # compute signature value
        my $signb64 = $algorithm->sign($key);
        $signature->data($signb64);

        # insert linebreaks in signature data, if desired
        $signature->prettify_safe();

        $self->{signature} = $signature;
        $self->{result}    = 'signed';
    }
}


sub add_signature {
    my $self      = shift;
    my $signature = shift;

    # create a canonicalization filter and algorithm
    my $algorithm_class =
      $signature->get_algorithm_class( $signature->algorithm )
      or die 'unsupported algorithm ' . ( $signature->algorithm || '' ) . "\n";
    my $algorithm = $algorithm_class->new(
        Signature              => $signature,
        Debug_Canonicalization => $self->{Debug_Canonicalization},
    );
    push @{ $self->{algorithms} }, $algorithm;
    return;
}


sub algorithm {
    my $self = shift;
    if ( @_ == 1 ) {
        $self->{Algorithm} = shift;
    }
    return $self->{Algorithm};
}


sub domain {
    my $self = shift;
    if ( @_ == 1 ) {
        $self->{Domain} = shift;
    }
    return $self->{Domain};
}



# these are headers that "should" be included in the signature,
# according to the DKIM spec.
my @DEFAULT_HEADERS = qw(From Sender Reply-To Subject Date
  Message-ID To Cc MIME-Version
  Content-Type Content-Transfer-Encoding Content-ID Content-Description
  Resent-Date Resent-From Resent-Sender Resent-To Resent-cc
  Resent-Message-ID
  In-Reply-To References
  List-Id List-Help List-Unsubscribe List-Subscribe
  List-Post List-Owner List-Archive);

sub process_headers_hash {
    my $self = shift;

    my @headers;

    # these are the header fields we found in the message we're signing
    my @found_headers = @{ $self->{header_field_names} };

    # Convert all keys to lower case
    foreach my $header ( keys %{ $self->{'ExtendedHeaders'} } ) {
        next if $header eq lc $header;
        if ( exists $self->{'ExtendedHeaders'}->{ lc $header } ) {

            # Merge
            my $first  = $self->{'ExtendedHeaders'}->{ lc $header };
            my $second = $self->{'ExtendedHeaders'}->{$header};
            if ( $first eq '+' || $second eq '+' ) {
                $self->{'ExtendedHeaders'}->{ lc $header } = '+';
            }
            elsif ( $first eq '*' || $second eq '*' ) {
                $self->{'ExtendedHeaders'}->{ lc $header } = '*';
            }
            else {
                $self->{'ExtendedHeaders'}->{ lc $header } = $first + $second;
            }
        }
        else {
            # Rename
            $self->{'ExtendedHeaders'}->{ lc $header } =
              $self->{'ExtendedHeaders'}->{$header};
        }
        delete $self->{'ExtendedHeaders'}->{$header};
    }

    # Add the default headers
    foreach my $default (@DEFAULT_HEADERS) {
        if ( !exists $self->{'ExtendedHeaders'}->{ lc $default } ) {
            $self->{'ExtendedHeaders'}->{ lc $default } = '*';
        }
    }

    # Build a count of found headers
    my $header_counts = {};
    foreach my $header (@found_headers) {
        if ( !exists $header_counts->{ lc $header } ) {
            $header_counts->{ lc $header } = 1;
        }
        else {
            $header_counts->{ lc $header } = $header_counts->{ lc $header } + 1;
        }
    }

    foreach my $header ( sort keys %{ $self->{'ExtendedHeaders'} } ) {
        my $want_count = $self->{'ExtendedHeaders'}->{$header};
        my $have_count = $header_counts->{ lc $header } || 0;
        my $add_count  = 0;
        if ( $want_count eq '+' ) {
            $add_count = $have_count + 1;
        }
        elsif ( $want_count eq '*' ) {
            $add_count = $have_count;
        }
        else {
            if ( $want_count > $have_count ) {
                $add_count = $have_count;
            }
            else {
                $add_count = $want_count;
            }
        }
        for ( 1 .. $add_count ) {
            push @headers, $header;
        }
    }
    return join( ':', @headers );
}

sub extended_headers {
    my $self = shift;
    $self->{'ExtendedHeaders'} = shift;
    return;
}

sub headers {
    my $self = shift;
    croak 'unexpected argument' if @_;

    if ( exists $self->{'ExtendedHeaders'} ) {
        return $self->process_headers_hash();
    }

    # these are the header fields we found in the message we're signing
    my @found_headers = @{ $self->{header_field_names} };

    # these are the headers we actually want to sign
    my @wanted_headers = @DEFAULT_HEADERS;
    if ( $self->{Headers} ) {
        push @wanted_headers, split /:/, $self->{Headers};
    }

    my @headers =
      grep {
        my $a = $_;
        scalar grep { lc($a) eq lc($_) } @wanted_headers
      } @found_headers;
    return join( ':', @headers );
}

# return nonzero if this is header we should sign
sub want_header {
    my $self = shift;
    my ($header_name) = @_;

    #TODO- provide a way for user to specify which headers to sign
    return scalar grep { lc($_) eq lc($header_name) } @DEFAULT_HEADERS;
}


sub key {
    my $self = shift;
    if (@_) {
        $self->{Key}     = shift;
        $self->{KeyFile} = undef;
    }
    return $self->{Key};
}


sub key_file {
    my $self = shift;
    if (@_) {
        $self->{Key}     = undef;
        $self->{KeyFile} = shift;
    }
    return $self->{KeyFile};
}


sub method {
    my $self = shift;
    if ( @_ == 1 ) {
        $self->{Method} = shift;
    }
    return $self->{Method};
}



sub selector {
    my $self = shift;
    if ( @_ == 1 ) {
        $self->{Selector} = shift;
    }
    return $self->{Selector};
}


sub signatures {
    my $self = shift;
    croak 'no arguments allowed' if @_;
    return map { $_->signature } @{ $self->{algorithms} };
}


1;

__END__