view release on metacpan or  search on metacpan

lib/Mail/Make/SMIME.pm  view on Meta::CPAN

    # Load recipient certificate(s) as public key(s)
    my @certs = ref( $recipient_cert ) eq 'ARRAY'
        ? @$recipient_cert
        : ( $recipient_cert );

    my @pem_certs;
    for my $cert ( @certs )
    {
        my $pem = $self->_read_pem( $cert ) || return( $self->pass_error );
        push( @pem_certs, $pem );
    }

    local $@;
    eval{ $smime->setPublicKey( \@pem_certs ) };
    return( $self->error( "encrypt(): failed to load recipient certificate(s): $@" ) ) if( $@ );

    # Serialise the full message
    my $raw = $self->_serialise_for_smime( $entity ) || return( $self->pass_error );

    my $encrypted;
    eval{ $encrypted = $smime->encrypt( $raw ) };
    return( $self->error( "encrypt(): Crypt::SMIME::encrypt() failed: $@" ) ) if( $@ );
    unless( defined( $encrypted ) && CORE::length( $encrypted ) )
    {
        return( $self->error( 'encrypt(): Crypt::SMIME returned empty result.' ) );
    }

    return( $self->_build_from_smime_output( $entity, $encrypted ) );
}

# key( [$pem_or_file] )
sub key { return( shift->_set_get_scalar( 'key', @_ ) ); }

# key_password( [$string_or_coderef] )
sub key_password { return( shift->_set_get_scalar( 'key_password', @_ ) ); }

# sign( entity => $mail_make [, %opts] )
# Signs $mail_make with a detached S/MIME signature. Returns a new Mail::Make
# object whose entity is a RFC 5751 multipart/signed message.
#
# Required option (or set via constructor / accessors):
#   entity  => Mail::Make object
#   Cert    => PEM string or file path   (overrides $self->{cert})
#   Key     => PEM string or file path   (overrides $self->{key})
#
# Optional options:
#   KeyPassword => string or CODE ref    (overrides $self->{key_password})
#   CACert      => PEM string or file path
sub sign
{
    my $self   = shift( @_ );
    my $opts   = $self->_get_args_as_hash( @_ );
    my $entity = $opts->{entity} ||
        return( $self->error( 'sign(): entity option is required.' ) );

    $self->_ensure_envelope_headers( $entity ) || return( $self->pass_error );

    my $smime = $self->_make_crypt_smime || return( $self->pass_error );

    $self->_load_private_key( $smime, $opts ) || return( $self->pass_error );

    $self->_load_ca_cert( $smime, $opts );    # optional; ignore error

    my $raw = $self->_serialise_for_smime( $entity ) || return( $self->pass_error );

    my $signed;
    local $@;
    eval{ $signed = $smime->sign( $raw ) };
    return( $self->error( "sign(): Crypt::SMIME::sign() failed: $@" ) ) if( $@ );
    unless( defined( $signed ) && CORE::length( $signed ) )
    {
        return( $self->error( 'sign(): Crypt::SMIME returned empty result.' ) );
    }

    return( $self->_build_from_smime_output( $entity, $signed ) );
}

# sign_encrypt( entity => $mail_make, RecipientCert => $cert [, %opts] )
# Signs then encrypts $mail_make. Returns a new Mail::Make object.
#
# Required options:
#   entity        => Mail::Make object
#   Cert          => PEM string or file path
#   Key           => PEM string or file path
#   RecipientCert => PEM string, file path, or arrayref
#
# Optional options:
#   KeyPassword => string or CODE ref
#   CACert      => PEM string or file path
#   Cipher      => 'DES3' | 'AES128' | 'AES256'
sub sign_encrypt
{
    my $self   = shift( @_ );
    my $opts   = $self->_get_args_as_hash( @_ );
    my $entity = $opts->{entity} ||
        return( $self->error( 'sign_encrypt(): entity option is required.' ) );

    $opts->{RecipientCert} ||
        return( $self->error( 'sign_encrypt(): RecipientCert option is required.' ) );

    $self->_ensure_envelope_headers( $entity ) || return( $self->pass_error );

    my $smime = $self->_make_crypt_smime || return( $self->pass_error );

    $self->_load_private_key( $smime, $opts ) || return( $self->pass_error );

    $self->_load_ca_cert( $smime, $opts );    # optional

    # Load recipient certificate(s)
    my @certs = ref( $opts->{RecipientCert} ) eq 'ARRAY'
        ? @{$opts->{RecipientCert}}
        : ( $opts->{RecipientCert} );

    my @pem_certs;
    for my $cert ( @certs )
    {
        my $pem = $self->_read_pem( $cert ) || return( $self->pass_error );
        push( @pem_certs, $pem );
    }

    local $@;
    eval{ $smime->setPublicKey( \@pem_certs ) };
    return( $self->error( "sign_encrypt(): failed to load recipient certificate(s): $@" ) ) if( $@ );

    my $raw = $self->_serialise_for_smime( $entity ) || return( $self->pass_error );

    # Crypt::SMIME has no signAndEncrypt() method. RFC 5751 sign-then-encrypt is
    # implemented by signing first, then encrypting the signed output.
    # The signed intermediate is a full RFC 2822 message string; we pass it directly to
    # encrypt() which operates on the same format.
    my $signed;
    eval{ $signed = $smime->sign( $raw ) };
    return( $self->error( "sign_encrypt(): Crypt::SMIME::sign() failed: $@" ) ) if( $@ );
    unless( defined( $signed ) && CORE::length( $signed ) )
    {
        return( $self->error( 'sign_encrypt(): Crypt::SMIME::sign() returned empty result.' ) );
    }

    # Re-load recipient public key(s) on a fresh instance for the encrypt step.
    # The same $smime object already has the private key loaded; calling setPublicKey()
    # again on it works, but to be explicit and avoid any state confusion we reuse $smime
    # (Crypt::SMIME accumulates public keys).
    my $result;
    eval{ $result = $smime->encrypt( $signed ) };
    return( $self->error( "sign_encrypt(): Crypt::SMIME::encrypt() failed: $@" ) ) if( $@ );
    unless( defined( $result ) && CORE::length( $result ) )
    {
        return( $self->error( 'sign_encrypt(): Crypt::SMIME::encrypt() returned empty result.' ) );
    }

    return( $self->_build_from_smime_output( $entity, $result ) );
}

# _build_from_smime_output( $original_mail, $smime_string ) → Mail::Make
# Parses the S/MIME output string from Crypt::SMIME (which already contains all the correct
# headers) into a new Mail::Make object that smtpsend() can use directly.
#
# Crypt::SMIME::sign() and encrypt() return a fully formed RFC 2822 message string. We
# wrap it in a Mail::Make object by parsing it into an Entity and storing it as 
# _smime_entity, mirroring what _gpg_entity does for GPG.
sub _build_from_smime_output
{
    my( $self, $original, $smime_str ) = @_;
    require Mail::Make;

lib/Mail/Make/SMIME.pm  view on Meta::CPAN

    # Copy envelope headers (From, To, Subject, Date, Message-ID …) from the original
    # Mail::Make object so that smtpsend() can derive the SMTP envelope
    # (MAIL FROM / RCPT TO) without inspecting the entity.
    $original->headers->scan( sub
    {
        my( $name, $value ) = @_;
        $new->headers->set( $name => $value );
        return(1);
    });

    # Store pre-assembled entity; as_entity() in Mail::Make returns it directly via the
    # _smime_entity hook.
    $new->{_smime_entity} = $entity;

    return( $new );
}

# _ensure_envelope_headers( $mail_make_obj )
# Generates Date and Message-ID on the Mail::Make object without calling as_entity(), to
# avoid polluting $self->{_parts}[0] with RFC 2822 headers.
sub _ensure_envelope_headers
{
    my( $self, $mail ) = @_;

    unless( $mail->{_headers}->exists( 'Date' ) )
    {
        $mail->{_headers}->init_header( Date => $mail->_format_date ) ||
            return( $self->pass_error( $mail->{_headers}->error ) );
    }

    unless( $mail->{_headers}->exists( 'Message-ID' ) )
    {
        $mail->{_headers}->message_id(
            { generate => 1, domain => $mail->_default_domain }
        ) || return( $self->pass_error( $mail->{_headers}->error ) );
    }

    return(1);
}

# _load_ca_cert( $smime_obj, \%opts )
# Loads the CA certificate into a Crypt::SMIME instance for chain verification.
# Source priority: option CACert > constructor ca_cert.
# Silently returns 1 if no CA cert is provided (CA cert is optional for signing).
sub _load_ca_cert
{
    my( $self, $smime, $opts_ref ) = @_;

    my $source = $opts_ref->{CACert} // $self->{ca_cert};
    return(1) unless( defined( $source ) && CORE::length( $source ) );

    my $pem = $self->_read_pem( $source ) || return( $self->pass_error );

    local $@;
    eval{ $smime->setPublicKey( [$pem] ) };
    return( $self->error( "_load_ca_cert(): failed to load CA certificate: $@" ) ) if( $@ );

    return(1);
}

# _load_private_key( $smime_obj, \%opts )
# Loads the private key and signing certificate into a Crypt::SMIME instance.
# Source priority: option Cert/Key > constructor cert/key.
# Handles key_password as string or CODE ref.
sub _load_private_key
{
    my( $self, $smime, $opts_ref ) = @_;

    my $cert_source = $opts_ref->{Cert} // $self->{cert};
    my $key_source  = $opts_ref->{Key}  // $self->{key};

    unless( defined( $cert_source ) && CORE::length( $cert_source ) )
    {
        return( $self->error( '_load_private_key(): no certificate provided. Set Cert option or cert() accessor.' ) );
    }

    unless( defined( $key_source ) && CORE::length( $key_source ) )
    {
        return( $self->error( '_load_private_key(): no private key provided. Set Key option or key() accessor.' ) );
    }

    my $cert_pem = $self->_read_pem( $cert_source ) || return( $self->pass_error );

    my $key_pem = $self->_read_pem( $key_source )   || return( $self->pass_error );

    # Resolve key password
    my $password_src = $opts_ref->{KeyPassword} // $self->{key_password};
    my $password;
    if( defined( $password_src ) )
    {
        if( ref( $password_src ) eq 'CODE' )
        {
            local $@;
            $password = eval{ $password_src->() };
            return( $self->error( "_load_private_key(): KeyPassword CODE ref died: $@" ) ) if( $@ );
        }
        else
        {
            $password = $password_src;
        }
    }

    local $@;
    if( defined( $password ) )
    {
        eval{ $smime->setPrivateKey( $key_pem, $cert_pem, $password ) };
    }
    else
    {
        eval{ $smime->setPrivateKey( $key_pem, $cert_pem ) };
    }
    return( $self->error( "_load_private_key(): failed to load private key/certificate: $@" ) ) if( $@ );

    return(1);
}

# _make_crypt_smime() → Crypt::SMIME instance
# Loads Crypt::SMIME and returns a new instance, with a clear error if the module is not
# installed.
sub _make_crypt_smime
{
    my $self = shift( @_ );
    $self->_load_class( 'Crypt::SMIME' ) ||
        return( $self->error( 'Crypt::SMIME is required for S/MIME operations. Install it with: cpan Crypt::SMIME' ) );

    my $smime;
    eval{ $smime = Crypt::SMIME->new };
    return( $self->error( "Failed to instantiate Crypt::SMIME: $@" ) ) if( $@ );

    return( $smime );
}

# _read_pem( $source ) → $pem_string
# Accepts either a PEM string (contains '-----BEGIN') or a file path and returns the PEM
# content as a string. Dies gracefully with a proper error.
sub _read_pem
{
    my( $self, $source ) = @_;

    unless( defined( $source ) )
    {
        return( $self->error( '_read_pem(): undefined source.' ) );
    }

    # Already a PEM string
    return( $source ) if( $source =~ /-----BEGIN/ );

    # File path
    unless( -f $source )
    {
        return( $self->error( "_read_pem(): file not found: $source" ) );
    }

    unless( -r $source )
    {
        return( $self->error( "_read_pem(): file not readable: $source" ) );
    }

    open( my $fh, '<', $source ) ||
        return( $self->error( "_read_pem(): cannot open '$source': $!" ) );
    local $/;
    my $pem = <$fh>;
    close( $fh );

    unless( defined( $pem ) && $pem =~ /-----BEGIN/ )
    {
        return( $self->error( "_read_pem(): file '$source' does not contain PEM data." ) );
    }

    return( $pem );
}