File Coverage

lib/Myco/Core/User.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package Myco::Core::User;

##############################################################################
# $Id: User.pm,v 1.1.1.1 2006/03/01 21:00:55 sommerb Exp $
#
# See license and copyright near the end of this file.
##############################################################################

=pod

=head1 NAME

Myco::Core::User - Interface to Myco User Objects

=head1 VERSION

1.0

=cut

our $VERSION = 1.0;

=pod

=head1 SYNOPSIS

  use Myco::Core::User;

  # Constructors.
  my $user = Myco::Core::User->new;
  # See Myco::Entity for more.

  # Class Methods.

  # Instance Methods.
  my $person = $user->get_person;
  $user->set_person($person);
  my $login = $user->login;
  $login->set_login($login);
  $user->set_pass($pass);
  if ($user->chk_pass($pass)) {
      # Allow access.
  }

  $user->save;
  $user->destroy;

=head1 DESCRIPTION

This Class provides the basic interface to all Myco user objects. It offers
the ability to set and get the login name, and to set and check the password.
The password is double-MD5 hash encrypted for security.

=cut

##############################################################################
# Dependencies
##############################################################################
# Module Dependencies and Compiler Pragma
use strict;
use warnings;
use Myco::Exceptions;

##############################################################################
# Programmatic Dependences
use Myco;
use Digest::MD5 ();
use Myco::Core::Person;
use Tangram::FlatHash;

##############################################################################
# Constants
##############################################################################
use constant DEBUG => 0;
use constant SECRET => 'YOUR SECRET HERE';

##############################################################################
# Class Variables
##############################################################################
my $_errors = {};

##############################################################################
# Inheritance & Introspection
##############################################################################
use base qw(Myco::Entity Myco::Association);
my $md = Myco::Entity::Meta->new
  ( name => __PACKAGE__,
    access_list => { rw => [qw(admin)] },
    tangram => { table => 'myco_user', # watch those SQL reserved words!
	         bases => [qw(Myco::Association)] },
    ui => { displayname => sub { shift->get_displayname },
	    list => { layout => [qw(login)] },
            view => { layout => [qw(login)] }, },
  );

##############################################################################
# Function and Closure Prototypes
#############################################################################
## Use this closure to check that a reference is to a Myco::Core::Person object.
my $chk_person = sub {
    Myco::Exception::DataValidation->throw
        (error => "'${$_[0]}' is not a Myco::Core::Person object")
          unless UNIVERSAL::isa(${$_[0]}, 'Myco::Core::Person')
};
# Use this closure to check that login is at least 4 letters or digits
my $chk_login = sub {
    my $login = $ {$_[0]};
    Myco::Exception::DataValidation->throw
        (error => 'Login must be 4 or more characters')
          if $login !~ /([A-Za-z]|\d){4,}/;
};
# Use this closure to check that pass is at least 6 letters or digits
my $chk_pass = sub {
  my $pass = $ {$_[0]};
  Myco::Exception::DataValidation->throw
      (error => 'Login must be 6 or more characters')
	if $pass !~ /([A-Za-z]|\d){6,}/;
};

##############################################################################
# Queries
##############################################################################

=head1 QUERIES

Myco::Query::Meta::Query objects defining generic and reusable queries for
finding Myco::Core::User objects.

=head2 default query

  my $metadata = Myco::Core::User->introspect->get_queries;
  my $default_query = $metadata->{default};
  my @results = $default_query->run_query(login => 'doej');

Find a user object with a given unique login attribute.

=head2 by_person query

  my $metadata = Myco::Core::User->introspect->get_queries;
  my $default_query = $metadata->{by_person};
  my @results = $default_query->run_query(person => $p);

Find a user object with a person attribute set to a given Myco::Core::Person
object, $p.

=cut

my $queries = sub {
    my $md = $_[0]; # Metadata object
    $md->add_query( name => 'default',
                    remotes => { '$u_' => 'Myco::Core::User', },
                    result_remote => '$u_',
                    params => {
                               login => [ qw($u_ login) ],
                              },
                    filter => { parts => [ { remote => '$u_',
                                             attr => 'login',
                                             oper => 'eq',
                                             param => 'login', },
                                         ] },
                  );

    $md->add_query( name => 'by_person',
                    remotes => { '$u_' => 'Myco::Core::User', },
                    result_remote => '$u_',
                    params => {
                               person => [ qw($u_ person) ],
                              },
                    filter => { parts => [
                                           { remote => '$u_',
                                             attr => 'person',
                                             oper => '==',
                                             param => 'person' },
                                         ] },
                  );
};

##############################################################################
# Constructor, etc.
##############################################################################

=head1 COMMON ENTITY INTERFACE

Constructor, accessors, and other methods -- as inherited from Myco::Entity.

=cut

##############################################################################
# Attributes & Attribute Accessors / Schema Definition
##############################################################################

=head1 ATTRIBUTES

Attributes may be initially set during object construction (with C) but
otherwise are accessed solely through accessor methods. Typical usage:

=over 2

=item *  Set attribute value

 $user->set_attribute($value);

Check functions (see L) perform data
validation. If there is any concern that the set method might be called with
invalid data then the call should be wrapped in an C block to catch
exceptions that would result.

=item *  Get attribute value

 $value = $user->get_attribute;

=back

Available attributes are listed below, using syntax borrowed from UML class
diagrams; for each showing the name, type, default initial value (if any),
and, following that, a description.

=over 4

=cut

##############################################################################

=item -person: ref(Myco::Core::Person) = Myco::Core::Person

The person object to which this user belongs. Access this object to output
name information about a user.

=cut

$md->add_attribute(name => 'person',
		   type => 'ref',
#                   access_list => { rw => [qw(admin)] },
		   synopsis => 'Person',
		   tangram_options => { check_func => $chk_person,
                                        required => 1,
                                        class => 'Myco::Core::Person' },
                  );


##############################################################################

=item -login: string(128) = undef

The userE<39>s login name.

=cut

$md->add_attribute( name => 'login',
                    type => 'string',
#                    access_list => { rw => [qw(admin)] },
                    synopsis => 'Login Name',
                    ui => { label => 'Login Name' },
                  );

##############################################################################

=item -pass: string(32) = undef

The userE<39>s login password. Internally, it will be encrypted in a double-MD5
hash before being stored in the system.

=cut

$md->add_attribute( name => 'pass',
                    type => 'string',
#                    access_list => { rw => [qw(admin)] },
                    synopsis => 'Password',
                    ui => { label => 'Password',
                            widget => [ 'password_field' ], },
                  );

# These are designed to prevent direct access to the password.

sub get_pass {
    Myco::Exception::MNI->throw
        (error => 'unknown method/attribute '.__PACKAGE__.'->get_pass called');
}
sub pass {
    Myco::Exception::MNI->throw
        (error => 'unknown method/attribute '.__PACKAGE__.'->pass called');
}

sub set_pass {
    my ($self, $pass) = @_;
    $self->SUPER::set_pass(
               Digest::MD5::md5_hex(SECRET . Digest::MD5::md5_hex($pass)));
    Myco::Exception::DataValidation->throw
        (error => 'Password must be at least 6 characters')
          if ($pass && length $pass < 6);
}

=item -roles: hash (string(64} => int) = {}

The userE<39>s roles. These are stored in a hash, where the keys are the role
names and the values are an integer, usually "1". Mostly, you shouldnE<39>t
use the hash to get at the roles, though. See below for the methods specific
to Role access.

=cut

$md->add_attribute( name => 'roles',
                    type => 'flat_hash',
#                    access_list => { rw => [qw(admin)] },
                    synopsis => 'Roles',
                    tangram_options => { table => 'user_roles',
                                         key_type => 'string',
                                         key_sql => 'VARCHAR(64) NOT NULL',
                                         type => 'int',
                                         sql => 'INT NOT NULL DEFAULT 1', },
                  );
# This is designed to prevent direct access to roles
sub roles {
    Myco::Exception::MNI->throw
      (error => 'unknown method/attribute '.__PACKAGE__.'->roles called');
}

=back

##############################################################################
# Methods
##############################################################################

=head1 ADDED CLASS / INSTANCE METHODS

=cut

=head2 chk_pass

  if ($user->chk_pass($pass)) {
      # Allow access.
  }

Checks the userE<39>s pass word or phrase. Returns true if the pass word or
phrase is correct, and false if it is not.

=cut

sub chk_pass {
  my ($self, $pass) = @_;
  # Use Class::Tangram::get() to get the password, because there won't yet
  # be a user when it's getting checked!
  my $oldpass = $self->SUPER::get_pass || return;
  return Digest::MD5::md5_hex(SECRET . Digest::MD5::md5_hex($pass)) eq
    $oldpass ? 1 : 0;
}

##############################################################################

=head2 get_roles

  my @roles = $user->get_roles;
  my $roles_aref = $user->get_roles;

Returns a list (in an array context) or an anonymous array (in a scalar
context) of all the roles assigned to the user.

=cut

sub get_roles {
    if ($_[0]->SUPER::get_roles) {
	wantarray ?
	  sort keys %{ $_[0]->SUPER::get_roles } :
	    [ sort keys %{ $_[0]->SUPER::get_roles } ];
    }
}

##############################################################################

=head2 add_roles

  $user->add_roles(@roles);

Adds the listed roles to the user. If any role in @roles does not actually
exist as a role, then C will throw an exception.

=cut

sub add_roles {
    my $self = shift;
    my $roles = $self->SUPER::get_roles;
    $self->SUPER::set_roles($roles = {}) unless $roles;
}

##############################################################################

=head2 del_roles

  $user->del_roles(@roles);

Deletes the listed roles from the user.

=cut

sub del_roles {
    my $self = shift;
    my $roles = $self->SUPER::get_roles;
    delete @{$roles}{@_};
}

##############################################################################

=head2 get_roles_hash

  $user->get_roles_hash;

Returns an anonymous hash of all of the roles assigned to the user. The hash
keys are the role names, and the values are a simple integer (usually one).
This is the internal representation of the roles in the User object, and
normally this method will only be used internally.

=cut

# This absolutely must use the Class::Tangram::get() method. To do otherwise
# will likely cause a problem with deep recursion in Myco::Entity.
# That's why it's best that this method only be used internally -- no one else
# should have permission to use it, really, anyway (except in chk_pass(),
# above).
sub get_roles_hash { $_[0]->SUPER::get_roles }


##############################################################################

=head2 get_displayname

  $user->get_displayname;

Returns the displayname of the person (first and last name) associated with a user.

=cut

sub get_displayname {
  my $self = shift;
  return $self->get_person->displayname;
}

##############################################################################

=head2 find_user

  my $u = Myco::Core::User->find_user($person);

Finds a user, given a Myco::Core::Person. This is a simple wrapper around the
'by_person' query contained in the Myco::Core::User query.

=cut

sub find_user {
  my $self = shift;
  my $p = shift;
  my ($u) = __PACKAGE__->introspect->get_queries->{by_person}->run
    (person => $p);
  return $u;
}


##############################################################################
# Throw a fatal Exception if $_errors is not empty


##############################################################################
# Object Schema Activation and Metadata Finalization
##############################################################################
$md->activate_class( queries => $queries );

1;
__END__