File Coverage

blib/lib/DBIx/Class/PassphraseColumn.pm

Criterion	Covered	Total	%
statement	57	58	98.2
branch	10	14	71.4
condition	4	8	50.0
subroutine	15	15	100.0
pod	3	3	100.0
total	89	98	90.8

use strict;
use warnings;

package DBIx::Class::PassphraseColumn; # git description: v0.03-8-ge50e692
# ABSTRACT: Automatically hash password/passphrase columns

our $VERSION = '0.04'; # TRIAL

use Module::Runtime 'require_module';
use Sub::Name 'subname';
use Encode ();
use namespace::clean;

use parent 'DBIx::Class';

#pod =head1 SYNOPSIS
#pod
#pod     __PACKAGE__->load_components(qw(PassphraseColumn));
#pod
#pod     __PACKAGE__->add_columns(
#pod         id => {
#pod             data_type         => 'integer',
#pod             is_auto_increment => 1,
#pod         },
#pod         passphrase => {
#pod             data_type        => 'text',
#pod             passphrase       => 'rfc2307',
#pod             passphrase_class => 'SaltedDigest',
#pod             passphrase_args  => {
#pod                 algorithm   => 'SHA-1',
#pod                 salt_random => 20,
#pod             },
#pod             passphrase_check_method => 'check_passphrase',
#pod         },
#pod     );
#pod
#pod     __PACKAGE__->set_primary_key('id');
#pod
#pod
#pod In application code:
#pod
#pod     # 'plain' will automatically be hashed using the specified passphrase_class
#pod     # and passphrase_args. The result of the hashing will stored in the
#pod     # specified encoding
#pod     $rs->create({ passphrase => 'plain' });
#pod
#pod     my $row = $rs->find({ id => $id });
#pod     my $passphrase = $row->passphrase; # an Authen::Passphrase instance
#pod
#pod     if ($row->check_passphrase($input)) { ...
#pod
#pod     $row->passphrase('new passphrase');
#pod     $row->passphrase( Authen::Passphrase::RejectAll->new );
#pod
#pod =head1 DESCRIPTION
#pod
#pod This component can be used to automatically hash password columns using any
#pod scheme supported by L whenever the value of these columns is
#pod changed.
#pod
#pod =head1 COMPARISON TO SIMILAR MODULES
#pod
#pod This module is similar to both L and
#pod L. Here's a brief comparison that might help you
#pod decide which one to choose.
#pod
#pod =over 4
#pod
#pod =item * C performs the hashing operation on C and
#pod C. C and C perform the operation when
#pod the value is set, or on C.
#pod
#pod =item * C supports only algorithms of the Digest family.
#pod
#pod =item * C employs a set of thin wrappers around different cipher
#pod modules to provide support for any cipher you wish to use and wrappers are very
#pod simple to write.
#pod
#pod =item * C delegates password hashing and encoding to
#pod C, which already has support for a huge number of hashing
#pod schemes. Writing a new C subclass to support other schemes
#pod is easy.
#pod
#pod =item * C and C require all values in a hashed column to
#pod use the same hashing scheme. C stores both the hashed
#pod passphrase value I the scheme used to hash it. Therefore it's possible to
#pod have different rows using different hashing schemes.
#pod
#pod This is especially useful when, for example, being tasked with importing records
#pod (e.g. users) from a legacy application, that used a certain hashing scheme and
#pod has no plain-text passwords available, into another application that uses
#pod another hashing scheme.
#pod
#pod =item * C and C support having more than one hashed
#pod column per table and each column can use a different hashing
#pod scheme. C is limited to one hashed column per table.
#pod
#pod =item * C supports changing certain options at runtime, as well as the
#pod option to not automatically hash values on set. Neither C nor
#pod C support this.
#pod
#pod =back
#pod
#pod =head1 OPTIONS
#pod
#pod This module provides the following options for C:
#pod
#pod =begin :list
#pod
#pod = C<< passphrase => $encoding >>
#pod
#pod This specifies the encoding that passphrases will be stored in. Possible values are
#pod C and C. The value of C<$encoding> is passed on unmodified to the
#pod C option provided by
#pod L. Please refer to its
#pod documentation for details.
#pod
#pod = C<< passphrase_class => $name >>
#pod
#pod When receiving a plain string value for a passphrase, that value will be hashed
#pod using the C subclass specified by C<$name>. A value of
#pod C, for example, will cause passphrases to be hashed using
#pod C.
#pod
#pod = C<< passphrase_args => \%args >>
#pod
#pod When attempting to hash a given passphrase, the C<%args> specified in this
#pod options will be passed to the constructor of the C class
#pod specified using C, in addition to the actual password to hash.
#pod
#pod = C<< passphrase_check_method => $method_name >>
#pod
#pod If this option is specified, a method with the name C<$method_name> will be
#pod created in the result class. This method takes one argument, a plain text
#pod passphrase, and returns a true value if the provided passphrase matches the
#pod encoded passphrase stored in the row it's being called on.
#pod
#pod =end :list
#pod
#pod =cut

__PACKAGE__->load_components(qw(InflateColumn::Authen::Passphrase));

__PACKAGE__->mk_classdata('_passphrase_columns');

#pod =method register_column
#pod
#pod Chains with the C method in C, and sets up
#pod passphrase columns according to the options documented above. This would not
#pod normally be directly called by end users.
#pod
#pod =cut

sub register_column {
    my ($self, $column, $info, @rest) = @_;

    if (my $encoding = $info->{passphrase}) {
        $info->{inflate_passphrase} = $encoding;

        $self->throw_exception(q['passphrase_class' is a required argument])
            unless exists $info->{passphrase_class}
                && defined $info->{passphrase_class};

        my $class = 'Authen::Passphrase::' . $info->{passphrase_class};
        require_module($class);

        my $args = $info->{passphrase_args} || {};
        $self->throw_exception(q['passphrase_args' must be a hash reference])
            unless ref $args eq 'HASH';

        my $encoder = sub {
            my ($val) = @_;
            $class->new(%{ $args }, passphrase => Encode::encode('UTF-8', $val))->${\"as_${encoding}"};
        };

        $self->_passphrase_columns({
            %{ $self->_passphrase_columns || {} },
            $column => $encoder,
        });

        if (defined(my $meth = $info->{passphrase_check_method})) {
            my $checker = sub {
                my ($row, $val) = @_;
                return $row->get_inflated_column($column)->match(Encode::encode('UTF-8', $val));
            };

            my $name = join q[::] => $self->result_class, $meth;

            {
                no strict 'refs';
                *$name = subname $name => $checker;
            }
        }
    }

    $self->next::method($column, $info, @rest);
}

#pod =method set_column
#pod
#pod Hash a passphrase column whenever it is set.
#pod
#pod =cut

sub set_column {
    my ($self, $col, $val, @rest) = @_;

    my $ppr_cols = $self->_passphrase_columns;
    return $self->next::method($col, $ppr_cols->{$col}->($val), @rest)
        if exists $ppr_cols->{$col};

    return $self->next::method($col, $val, @rest);
}

#pod =method new
#pod
#pod Hash all passphrase columns on C so that C, C, and
#pod others B.
#pod
#pod =cut

sub new {
    my ($self, $attr, @rest) = @_;

    my $ppr_cols = $self->_passphrase_columns;
    for my $col (keys %{ $ppr_cols }) {
        next unless exists $attr->{$col} && !ref $attr->{$col};
        $attr->{$col} = $ppr_cols->{$col}->( $attr->{$col} );
    }

    return $self->next::method($attr, @rest);
}

#pod =head1 SEE ALSO
#pod
#pod L
#pod
#pod L
#pod
#pod L
#pod
#pod =cut

1;

__END__