File Coverage

blib/lib/Mail/DKIM/Signature.pm

Criterion	Covered	Total	%
statement	226	260	86.9
branch	110	140	78.5
condition	16	20	80.0
subroutine	46	52	88.4
pod	25	40	62.5
total	423	512	82.6

package Mail::DKIM::Signature;
use strict;
use warnings;
our $VERSION = '1.20240923'; # VERSION
# ABSTRACT: represents a DKIM-Signature header

# 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::PublicKey;
use Mail::DKIM::Algorithm::rsa_sha1;
use Mail::DKIM::Algorithm::rsa_sha256;
use Mail::DKIM::Algorithm::ed25519_sha256;

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


sub new {
    my $class = shift;
    my %prms  = @_;
    my $self  = {};
    bless $self, $class;

    $self->version('1');
    $self->algorithm( $prms{'Algorithm'} || 'rsa-sha1' );
    $self->signature( $prms{'Signature'} );
    $self->canonicalization( $prms{'Method'} ) if exists $prms{'Method'};
    $self->domain( $prms{'Domain'} );
    $self->headerlist( $prms{'Headers'} );
    $self->protocol( $prms{'Query'} ) if exists $prms{'Query'};
    $self->selector( $prms{'Selector'} );
    $self->identity( $prms{'Identity'} )     if exists $prms{'Identity'};
    $self->timestamp( $prms{'Timestamp'} )   if defined $prms{'Timestamp'};
    $self->expiration( $prms{'Expiration'} ) if defined $prms{'Expiration'};
    $self->tags( $prms{'Tags'} ) if defined $prms{'Tags'};
    $self->key( $prms{'Key'} )               if defined $prms{'Key'};
    return $self;
}


sub parse {
    my $class = shift;
    croak 'wrong number of arguments' unless ( @_ == 1 );
    my ($string) = @_;

    # remove line terminator, if present
    $string =~ s/\015\012\z//;

    # remove field name, if present
    my $prefix = $class->prefix();
    if ( $string =~ s/^($prefix)//i ) {

        # save the field name (capitalization), so that it can be
        # restored later
        $prefix = $1;
    }

    my $self = $class->SUPER::parse($string);
    $self->{prefix} = $prefix;

    return $self;
}


# deprecated
sub wantheader {
    my $self = shift;
    my $attr = shift;

    $self->headerlist
      or return 1;

    foreach my $key ( $self->headerlist ) {
        lc $attr eq lc $key
          and return 1;
    }

    return;
}


sub algorithm {
    my $self = shift;

    if (@_) {
        $self->set_tag( 'a', shift );
    }

    my $a = $self->get_tag('a');
    return defined $a ? lc $a : undef;
}


sub as_string {
    my $self = shift;

    return $self->prefix() . $self->SUPER::as_string;
}

# undocumented method
sub as_string_debug {
    my $self = shift;

    return $self->prefix()
      . join( ';', map { '>' . $_->{raw} . '<' } @{ $self->{tags} } );
}


sub as_string_without_data {
    my $self = shift;
    croak 'wrong number of arguments' unless ( @_ == 0 );

    my $alt = $self->clone;
    $alt->signature('');

    return $alt->as_string;
}


sub body_count {
    my $self = shift;

    # set new body count if provided
    (@_)
      and $self->set_tag( 'l', shift );

    return $self->get_tag('l');
}


sub body_hash {
    my $self = shift;

    # set new body hash if provided
    (@_)
      and $self->set_tag( 'bh', shift );

    my $result = $self->get_tag('bh');
    if ( defined $result ) {
        $result =~ s/\s+//gs;
    }
    return $result;
}


sub canonicalization {
    my $self = shift;

    if (@_) {
        $self->set_tag( 'c', join( '/', @_ ) );
    }

    my $c = $self->get_tag('c');
    $c = lc $c if defined $c;
    if ( not $c ) {
        $c = 'simple/simple';
    }
    my ( $c1, $c2 ) = split( /\//, $c, 2 );
    if ( not defined $c2 ) {

        # default body canonicalization is "simple"
        $c2 = 'simple';
    }

    if (wantarray) {
        return ( $c1, $c2 );
    }
    else {
        return "$c1/$c2";
    }
}

use MIME::Base64;

# checks whether this signature specifies a legal canonicalization method
# returns true if the canonicalization is acceptable, false otherwise
#
sub check_canonicalization {
    my $self = shift;

    my ( $c1, $c2 ) = $self->canonicalization;

    my @known = ( 'nowsp', 'simple', 'relaxed', 'seal' );
    return undef unless ( grep { $_ eq $c1 } @known );
    return undef unless ( grep { $_ eq $c2 } @known );
    return 1;
}

sub set_verify_time {
    my ( $self, $verify_time ) = @_;
    $self->{_verify_time} = $verify_time;
}

# checks whether the expiration time on this signature is acceptable
# returns a true value if acceptable, false otherwise
#
sub check_expiration {
    my $self = shift;
    my $x    = $self->expiration;
    return 1 if not defined $x;
    $self->{_verify_time} ||= time();
    return ( $self->{_verify_time} <= $x );
}

# Returns a filtered list of protocols that can be used to fetch the
# public key corresponding to this signature. An empty list means that
# all designated protocols are unrecognized.
# Note: at this time, the only recognized protocol is "dns/txt".
#
sub check_protocol {
    my $self = shift;

    my $v = $self->version;

    foreach my $prot ( split /:/, $self->protocol ) {
        my ( $type, $options ) = split( /\//, $prot, 2 );
        if ( $type eq 'dns' ) {
            return ('dns/txt') if $options && $options eq 'txt';

            # prior to DKIM version 1, the '/txt' part was optional
            if ( !$v ) {
                return ('dns/txt') if !defined($options);
            }
        }
    }

    # unrecognized
    return;
}

# checks whether the version tag has an acceptable value
# returns true if so, otherwise false
#
sub check_version {
    my $self = shift;

    # check version
    if ( my $version = $self->version ) {
        my @ALLOWED_VERSIONS = ( '0.5', '1' );
        return ( grep { $_ eq $version } @ALLOWED_VERSIONS );
    }

    # we still consider a missing v= tag acceptable,
    # for backwards-compatibility
    return 1;
}


sub data {
    my $self = shift;

    if (@_) {
        $self->set_tag( 'b', shift );
    }

    my $b = $self->get_tag('b');
    $b =~ tr/\015\012 \t//d if defined $b;
    return $b;
}

*signature = \*data;

#undocumented, private function
#derived from MIME::Base64::Perl (allowed, thanks to the Perl license)
#
sub decode_qp {
    my $res = shift;

    #TODO- should I worry about non-ASCII systems here?
    $res =~ s/=([\da-fA-F]{2})/pack('C', hex($1))/ge
      if defined $res;
    return $res;
}

#undocumented, private function
#derived from MIME::Base64::Perl (allowed, thanks to the Perl license)
#
sub encode_qp {
    my $res = shift;

    # note- unlike MIME quoted-printable, we don't allow whitespace chars
    my $DISALLOWED = qr/[^!"#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~]/;

    #TODO- should I worry about non-ASCII systems here?
    $res =~ s/($DISALLOWED)/sprintf('=%02X', ord($1))/eg
      if defined $res;
    return $res;
}

sub DEFAULT_PREFIX {
    return 'DKIM-Signature:';
}

sub prefix {
    my $class = shift;
    if ( ref($class) ) {
        $class->{prefix} = shift if @_;
        return $class->{prefix} if $class->{prefix};
    }
    return $class->DEFAULT_PREFIX();
}


sub domain {
    my $self = shift;

    if (@_) {
        $self->set_tag( 'd', shift );
    }

    my $d = $self->get_tag('d');
    return defined $d ? lc $d : undef;
}


sub expiration {
    my $self = shift;

    (@_)
      and $self->set_tag( 'x', shift );

    return $self->get_tag('x');
}

sub tags {
    my $self = shift;
    my $tags = shift;

    for my $tag (sort keys %$tags) {
      $self->set_tag( $tag, $tags->{$tag} );
    }
    (@_)

}

# allows the type of signature to determine what "algorithm" gets used
sub get_algorithm_class {
    my $self = shift;
    croak 'wrong number of arguments' unless ( @_ == 1 );
    my ($algorithm) = @_;

    my $class =
        $algorithm eq 'rsa-sha1'   ? 'Mail::DKIM::Algorithm::rsa_sha1'
      : $algorithm eq 'rsa-sha256' ? 'Mail::DKIM::Algorithm::rsa_sha256'
      : $algorithm eq 'ed25519-sha256' ? 'Mail::DKIM::Algorithm::ed25519_sha256'
      :                              undef;
    return $class;
}

# [private method]
# fetch_public_key() - initiate a DNS query for fetching the key
#
# This method does NOT return the public key.
# Use get_public_key() for that.
#
sub fetch_public_key {
    my $self = shift;
    return if exists $self->{public_key_query};

    my $on_success = sub {
        if ( $_[0] ) {
            $self->{public} = $_[0];
        }
        else {
            $self->{public_error} = "not available\n";
        }
    };

    my @methods = $self->check_protocol;
    $self->{public_key_query} = Mail::DKIM::PublicKey->fetch_async(
        Protocol  => $methods[0],
        Selector  => $self->selector,
        Domain    => $self->domain,
        Callbacks => {
            Success => $on_success,
            Error   => sub { $self->{public_error} = shift },
        },
    );
    return;
}

#EXPERIMENTAL
sub _refetch_public_key {
    my $self = shift;
    if ( $self->{public_key_query} ) {

        # clear the existing query by waiting for it to complete
        $self->{public_key_query}->();
    }
    delete $self->{public_key_query};
    delete $self->{public};
    delete $self->{public_error};
    $self->fetch_public_key;
}


sub get_public_key {
    my $self = shift;

    # this ensures we only try fetching once, even if an error occurs
    if ( not exists $self->{public_key_query} ) {
        $self->fetch_public_key;
    }

    if ( $self->{public_key_query} ) {

        # wait for public key query to finish
        $self->{public_key_query}->();
        $self->{public_key_query} = 0;
    }

    if ( exists $self->{public} ) {
        return $self->{public};
    }
    else {
        die $self->{public_error};
    }
}


sub hash_algorithm {
    my $self      = shift;
    my $algorithm = $self->algorithm;

    return
        $algorithm eq 'rsa-sha1'   ? 'sha1'
      : $algorithm eq 'rsa-sha256' ? 'sha256'
      : $algorithm eq 'ed25519-sha256' ? 'sha256'
      :                              undef;
}


sub headerlist {
    my $self = shift;

    (@_)
      and $self->set_tag( 'h', shift );

    my $h = $self->get_tag('h') || '';

    # remove whitespace next to colons
    $h =~ s/\s+:/:/g;
    $h =~ s/:\s+/:/g;
    $h = lc $h;

    if ( wantarray and $h ) {
        my @list = split /:/, $h;
        @list = map { s/^\s+|\s+$//g; $_ } @list;
        return @list;
    }
    elsif (wantarray) {
        return ();
    }

    return $h;
}


sub identity {
    my $self = shift;

    # set new identity if provided
    (@_)
      and $self->set_tag( 'i', encode_qp(shift) );

    my $i = $self->get_tag('i');
    if ( defined $i ) {
        return decode_qp($i);
    }
    else {
        return '@' . ( $self->domain || '' );
    }
}

sub identity_matches {
    my $self = shift;
    my ($addr) = @_;

    my $id = $self->identity;
    if ( $id =~ /^\@/ ) {

        # the identity is a domain-name only, so it only needs to match
        # the domain part of the sender address
        return ( lc( substr( $addr, -length($id) ) ) eq lc($id) );

        # TODO - compare the parent domains?
    }
    return lc($addr) eq lc($id);
}


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


sub method {
    my $self = shift;

    if (@_) {
        $self->set_tag( 'c', shift );
    }

    return ( lc $self->get_tag('c') ) || 'simple';
}


sub protocol {
    my $self = shift;

    (@_)
      and $self->set_tag( 'q', shift );

    my $q = $self->get_tag('q');
    if ( defined $q ) {
        return $q;
    }
    else {
        return 'dns/txt';
    }
}


sub result {
    my $self = shift;
    @_ and $self->{verify_result}  = shift;
    @_ and $self->{verify_details} = shift;
    return $self->{verify_result};
}


sub result_detail {
    my $self = shift;
    croak 'wrong number of arguments' unless ( @_ == 0 );

    if ( $self->{verify_result} && $self->{verify_details} ) {
        return $self->{verify_result} . ' (' . $self->{verify_details} . ')';
    }
    return $self->{verify_result};
}


sub selector {
    my $self = shift;

    (@_)
      and $self->set_tag( 's', shift );

    return $self->get_tag('s');
}


sub prettify {
    my $self = shift;
    $self->wrap(
        Start => length( $self->prefix() ),
        Tags  => {
            b  => 'b64',
            bh => 'b64',
            h  => 'list',
        },
    );
}


sub prettify_safe {
    my $self = shift;
    $self->wrap(
        Start => length( $self->prefix() ),
        Tags  => {
            b => 'b64',
        },
        PreserveNames => 1,
        Default       => 'preserve',    #preserves unknown tags
    );
}


sub timestamp {
    my $self = shift;

    (@_)
      and $self->set_tag( 't', shift );

    return $self->get_tag('t');
}


sub version {
    my $self = shift;

    (@_)
      and $self->set_tag( 'v', shift );

    return $self->get_tag('v');
}


1;

__END__