File Coverage

blib/lib/Interchange6/Schema/Result/User.pm

Criterion	Covered	Total	%
statement	98	99	100.0
branch	34	36	97.2
condition	12	12	100.0
subroutine	21	21	100.0
pod	12	12	100.0
total	177	180	99.4

use utf8;

package Interchange6::Schema::Result::User;

=head1 NAME

Interchange6::Schema::Result::User

=cut

use base 'Interchange6::Schema::Base::Attribute';

use Interchange6::Schema::Candy -components =>
  [qw(InflateColumn::DateTime PassphraseColumn TimeStamp)];

use Class::Method::Modifiers;
use Data::UUID;
use DateTime;
use Digest::MD5;
use DateTime;
use Session::Token;

=head1 ACCESSORS

=head2 users_id

Primary key.

=cut

primary_column users_id => {
    data_type         => "integer",
    is_auto_increment => 1,
    sequence          => "users_users_id_seq",
};

=head2 username

The username is automatically converted to lowercase so
we make sure that the unique constraint on username works.

=cut

unique_column username => {
    data_type   => "varchar",
    size        => 255,
    accessor    => '_username',
};

sub username {
    my $self = shift;
    if ( @_ ) {
        my $value = shift;
        $value = check_username($value);
        $self->_username($value);
    }
    return $self->_username();
}

=head2 nickname

Unique nickname for user.

=cut

unique_column nickname => {
    data_type   => "varchar",
    is_nullable => 1,
    size        => 255,
};

=head2 email

email address.

=cut

column email => {
    data_type     => "varchar",
    default_value => "",
    size          => 255,
};

=head2 password

See L<DBIx::Class::PassphraseColumn> and its dependency
L<Authen::Passphrase> for full details of supported password encodings.

New/changed passwords are currently encoded using
L<Authen::Passphrase::BlowfishCrypt> using 2^14 rounds and random salt.

Check password method is C<check_password>.

Default value is '{CRYPT}*' which causes C<check_password> to fail.

=cut

column password => {
    data_type        => "varchar",
    size             => 2048,
    default_value    => '*', # reject
    passphrase       => 'crypt',
    passphrase_class => 'BlowfishCrypt',
    passphrase_args  => {
        cost        => 14,
        key_nul     => 1,
        salt_random => 1,
    },
    passphrase_check_method => 'check_password',
};

around 'check_password' => sub {
    my $orig = shift;
    my $self = shift;
    my $ret;
    # DBIx::Class::PassphraseColumn v0.02 can throw exceptions so use eval.
    # Must investigate further why column inflation sometimes returns undef
    # which cause ->match to fail.
    eval { $ret = $orig->($self, @_) };
    if ( $ret ) {
        $self->update( { fail_count => 0, last_login => DateTime->now } );
    }
    else {
        $self->update( { fail_count => ( $self->fail_count || 0 ) + 1 } );
    }
    return $ret;
};

=head2 first_name

User's first name.

=cut

column first_name => {
    data_type     => "varchar",
    default_value => "",
    size          => 255,
};

=head2 last_name

User's last name.

=cut

column last_name => {
    data_type     => "varchar",
    default_value => "",
    size          => 255,
};

=head2 last_login

Last login returned as L<DateTime> object. Updated on successful call to
C<check_password>.

=cut

column last_login => {
    data_type   => "datetime",
    is_nullable => 1,
};

=head2 fail_count

Count of failed logins since last successful login. On successful call to
C<check_password> gets reset to zero but on fail is incremented.

=cut

column fail_count => {
    data_type     => "integer",
    default_value => 0,
};

=head2 reset_expires

Date and time when L</reset_token> expires.

=cut

column reset_expires => {
    data_type   => "datetime",
    is_nullable => 1,
};

=head2 reset_token

Used to store password reset token.

=cut

column reset_token => {
    data_type   => "varchar",
    size        => 255,
    is_nullable => 1,
};

=head2 is_anonymous

Boolean denoting an anonymous user. Defaults to 0 (false);

=cut

column is_anonymous => {
    data_type     => "boolean",
    default_value => 0,
};

=head2 created

Date and time when this record was created returned as L<DateTime> object.
Value is auto-set on insert.

=cut

column created => {
    data_type     => "datetime",
    set_on_create => 1,
};

=head2 last_modified

Date and time when this record was last modified returned as L<DateTime> object.
Value is auto-set on insert and update.

=cut

column last_modified => {
    data_type     => "datetime",
    set_on_create => 1,
    set_on_update => 1,
};

=head2 active

Is this user account active? Default is yes.

=cut

column active => {
    data_type     => "boolean",
    default_value => 1,
};

=head1 RELATIONS

=head2 addresses

Type: has_many

Related object: L<Interchange6::Schema::Result::Address>

=cut

has_many
  addresses => "Interchange6::Schema::Result::Address",
  "users_id",
  { cascade_copy => 0, cascade_delete => 0 };

=head2 carts

Type: has_many

Related object: L<Interchange6::Schema::Result::Cart>

=cut

has_many
  carts => "Interchange6::Schema::Result::Cart",
  "users_id",
  { cascade_copy => 0, cascade_delete => 0 };

=head2 orders

Type: has_many

Related object: L<Interchange6::Schema::Result::Order>

=cut

has_many
  orders => "Interchange6::Schema::Result::Order",
  "users_id",
  { cascade_copy => 0, cascade_delete => 0 };

=head2 user_attributes

Type: has_many

Related object: L<Interchange6::Schema::Result::UserAttribute>

=cut

has_many
  user_attributes => "Interchange6::Schema::Result::UserAttribute",
  "users_id",
  { cascade_copy => 0, cascade_delete => 0 };

=head2 user_roles

Type: has_many

Related object: L<Interchange6::Schema::Result::UserRole>

=cut

has_many
  user_roles => "Interchange6::Schema::Result::UserRole",
  "users_id";

=head2 roles

Type: many_to_many

Composing rels: L</user_roles> -> role

=cut

many_to_many roles => "user_roles", "role";

=head2 approvals

Type: has_many

Related object: L<Interchange6::Schema::Result::Message> FK C<approved_by_users_id>

=cut

has_many
  approvals => "Interchange6::Schema::Result::Message",
  { 'foreign.approved_by_users_id' => 'self.users_id' };

=head2 messages

Type: has_many

Related object: L<Interchange6::Schema::Result::Message> FK C<author_users_id>

=cut

has_many
  messages => "Interchange6::Schema::Result::Message",
  { 'foreign.author_users_id' => 'self.users_id' };

=head1 METHODS

Attribute methods are provided by the L<Interchange6::Schema::Base::Attribute> class.

=head2 sqlt_deploy_hook

Called during table creation to add indexes on the following columns:

=over 4

=item * reset_token

=back

=cut

sub sqlt_deploy_hook {
    my ( $self, $table ) = @_;

    $table->add_index(
        name   => 'users_idx_reset_token',
        fields => ['reset_token']
    );
}

=head2 reset_token_generate( %args );

Arguments should be a hash of the following key/value pairs:

=over

=item * duration => $datetime_duration_hashref

Value should be a hash reference containing values that can be passed directly
to L<DateTime::Duration/new>. Passing an undef value to duration will lead
to the creation of a reset token that does not expire. Default duration is
24 hours.

=item * entropy => $number_of_bits

The number of bits of entropy to be used by L<Session::Token/new>. Defaults
to 128.

=back

This method sets L</reset_expires> and L</reset_token> and returns the value
of L</reset_token> with checksum added.

=cut

sub reset_token_generate {
    my ( $self, %args ) = @_;

    if ( exists $args{duration} && !defined $args{duration} ) {

        # we got undef duration so clear reset_expires

        $self->reset_expires(undef);
    }
    else {

        # attempt to set reset_expires to appropriate value

        if ( $args{duration} ) {
            $self->throw_exception(
                "duration arg to reset_token_generate must be a hashref")
              unless ref( $args{duration} ) eq 'HASH';
        }
        else {
            $args{duration} = { hours => 24 };
        }

        my $dt = DateTime->now;
        $dt->add( %{$args{duration}} );
        $self->reset_expires($dt);
    }

    # generate random token and store it in the DB

    # Session::Token->new assumes entropy is numeric but first check is '>'
    # which causes a warning on non-numeric so we check here 1st
    die "bad value for entropy"
      if ( $args{entropy} && $args{entropy} !~ /^\d+$/ );

    # set default entropy if not defined
    $args{entropy} = 128 unless $args{entropy};

    my $token = Session::Token->new( entropy => $args{entropy} )->get;
    $self->reset_token( $token );

    # flush changes to DB

    $self->update;

    # return combined token and checksum

    return join( "_", $token, $self->reset_token_checksum($token) );
}

=head2 reset_token_checksum

Returns the checksum for the token stored in L</reset_token>.

Checksum is a digest of L</password>, L</reset_token> and L</reset_expires>
(if this is defined). This ensures that a reset token is not valid if password
has changed or if a newer token has been generated.

=cut

sub reset_token_checksum {
    my $self = shift;
    my $digest = Digest::MD5->new();
    $digest->add( $self->password->as_crypt ) if $self->password;
    $digest->add( $self->reset_token );
    $digest->add( $self->reset_expires->datetime ) if $self->reset_expires;
    return $digest->hexdigest();
}

=head2 reset_token_verify

When passed combined token and checksum as argument returns 1 if token
and checksum are correct and L</reset_expires> is not in the past (if
it is defined). Returns 0 on failure.

=cut

sub reset_token_verify {
    my $self = shift;
    my ( $token, $checksum ) = split(/_/, shift);

    $self->throw_exception("Bad argument to reset_token_verify")
      unless $checksum;

    # check token and expiry against DB and compare checksum

    # The following should be combined in a single 'if' statement but sadly
    # we then end up with Devel::Cover being unable to test the condition
    # correctly so instead we break it out into ugly code. At least it
    # means we know our tests are covering all condition. :(
    if ( $self->reset_token eq $token ) {
        if ( !$self->reset_expires || DateTime->now <= $self->reset_expires ) {
            if ( $self->reset_token_checksum eq $checksum ) {
                return 1;
            }
        }
    }
    return 0;
}

=head2 new

Overloaded method.

If L</username> is undefined and L</is_anonymous> is defined then create
a unique username for this anonymous user and set L</active> to false.
Otherwise check username using L</check_username>.

=cut

sub new {
    my ( $class, $attrs ) = @_;

    if ( defined $attrs->{is_anonymous} && !defined $attrs->{username} ) {
        my $ug = Data::UUID->new;
        $attrs->{username} = "anonymous-" . lc( $ug->create_str );
        $attrs->{active}   = 0;
    }
    else {
        $attrs->{username} = check_username($attrs->{username});
    }

    my $new = $class->next::method($attrs);
    return $new;
}

=head2 insert

Overloaded method. Always add new users to Role with name 'user' unless user
has L</is_anonymous> set in which case add user to role 'anonymous';

=cut

sub insert {
    my ($self, @args) = @_;

    my $guard = $self->result_source->schema->txn_scope_guard;

    $self->next::method(@args);

    my $role_name = $self->is_anonymous ? 'anonymous' : 'user';

    my $user_role = $self->result_source->schema->resultset('Role')
      ->find( { name => $role_name } );

    # uncoverable branch false
    if ( $user_role ) {
        $self->create_related( 'user_roles', { roles_id => $user_role->id } );
    }
    else {
        # we should never get here
        # uncoverable statement
        $self->throw_exception(
            "Role with name 'user' must exist when creating a new user");
    }

    $guard->commit;
    return $self;
}

=head2 update

Overloaded method. Check username using L</check_username> if supplied.

=cut

sub update {
    my ( $self, $upd ) = @_;

    my $username;

    # username may have been passed as arg or previously set

    if ( exists $upd->{username} ) {
        $upd->{username} = check_username($upd->{username});
    }

    return $self->next::method($upd);
}

=head2 check_username( $username )

Die if C<$username> is undef or empty string. Otherwise return C<lc($username)>

=cut

sub check_username {
    my $value = shift;
    die "username cannot be undef" unless defined $value;
    $value =~ s/(^\s+|\s+$)//g;
    die "username cannot be empty string" if $value eq '';
    return lc($value);
}

=head2 blog_posts

Returns resultset of messages that are blog posts

=cut

sub blog_posts {
    my $self = shift;
    return $self->messages->search( { 'message_type.name' => 'blog_post' },
        { join => 'message_type' } );
}

=head2 name

Returns L</first_name> and L</last_name> joined by a single space.

=cut

sub name {
    my $self = shift;
    return join( " ", $self->first_name, $self->last_name );
}

=head2 reviews

Returns resultset of messages that are reviews.

=cut

sub reviews {
    my $self = shift;
    return $self->messages->search( { 'message_type.name' => 'product_review' },
        { join => 'message_type' } );
}

1;