[scpubgit/stemmatology.git] / lib / Text / Tradition / Directory.pm

package Text::Tradition::Directory;

use strict;
use warnings;
use Moose;
use DBI;
use Encode qw/ decode_utf8 /;
use KiokuDB::GC::Naive;
use KiokuDB::TypeMap;
use KiokuDB::TypeMap::Entry::Naive;
use Text::Tradition::Error;

## users
use KiokuX::User::Util qw(crypt_password);
use Text::Tradition::User;

extends 'KiokuX::Model';

=head1 NAME

Text::Tradition::Directory - a KiokuDB interface for storing and retrieving traditions

=head1 SYNOPSIS

  use Text::Tradition::Directory;
  my $d = Text::Tradition::Directory->new( 
    'dsn' => 'dbi:SQLite:mytraditions.db',
    'extra_args' => { 'create' => 1 },
  );
  
  my $tradition = Text::Tradition->new( @args );
  my $stemma = $tradition->add_stemma( dotfile => $dotfile ); 
  $d->save_tradition( $tradition );
  
  foreach my $id ( $d->traditions ) {
  	print $d->tradition( $id )->name;
  }
    
=head1 DESCRIPTION

Text::Tradition::Directory is an interface for storing and retrieving text traditions and all their data, including an associated stemma hypothesis.  It is an instantiation of a KiokuDB::Model, storing traditions and associated stemmas by UUID.

=head1 METHODS

=head2 new

Returns a Directory object. 

=head2 traditionlist

Returns a hashref mapping of ID => name for all traditions in the directory.

=head2 tradition( $id )

Returns the Text::Tradition object of the given ID.

=head2 save( $tradition )

Writes the given tradition to the database, returning its ID.

=head2 delete( $tradition )

Deletes the given tradition object from the database.
WARNING!! Garbage collection does not yet work. Use this sparingly.

=begin testing

use TryCatch;
use File::Temp;
use Text::Tradition;
use_ok 'Text::Tradition::Directory';

my $fh = File::Temp->new();
my $file = $fh->filename;
$fh->close;
my $dsn = "dbi:SQLite:dbname=$file";
my $uuid;
my $t = Text::Tradition->new( 
	'name'  => 'inline', 
	'input' => 'Tabular',
	'file'  => 't/data/simple.txt',
	);

{
	my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
		'extra_args' => { 'create' => 1 } );
	is( ref $d, 'Text::Tradition::Directory', "Got directory object" );
	
	my $scope = $d->new_scope;
	$uuid = $d->save( $t );
	ok( $uuid, "Saved test tradition" );
	
	my $s = $t->add_stemma( dotfile => 't/data/simple.dot' );
	ok( $d->save( $t ), "Updated tradition with stemma" );
	is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" );
	is( $d->tradition( $uuid )->stemma(0), $s, "...and it has the correct stemma" );
	try {
		$d->save( $s );
	} catch( Text::Tradition::Error $e ) {
		is( $e->ident, 'database error', "Got exception trying to save stemma directly" );
		like( $e->message, qr/Cannot directly save non-Tradition object/, 
			"Exception has correct message" );
	}
}
my $nt = Text::Tradition->new(
	'name' => 'CX',
	'input' => 'CollateX',
	'file' => 't/data/Collatex-16.xml',
	);
is( ref( $nt ), 'Text::Tradition', "Made new tradition" );

{
	my $f = Text::Tradition::Directory->new( 'dsn' => $dsn );
	my $scope = $f->new_scope;
	is( scalar $f->traditionlist, 1, "Directory index has our tradition" );
	my $nuuid = $f->save( $nt );
	ok( $nuuid, "Stored second tradition" );
	my @tlist = $f->traditionlist;
	is( scalar @tlist, 2, "Directory index has both traditions" );
	my $tf = $f->tradition( $uuid );
	my( $tlobj ) = grep { $_->{'id'} eq $uuid } @tlist;
	is( $tlobj->{'name'}, $tf->name, "Directory index has correct tradition name" );
	is( $tf->name, $t->name, "Retrieved the tradition from a new directory" );
	my $sid = $f->object_to_id( $tf->stemma(0) );
	try {
		$f->tradition( $sid );
	} catch( Text::Tradition::Error $e ) {
		is( $e->ident, 'database error', "Got exception trying to fetch stemma directly" );
		like( $e->message, qr/not a Text::Tradition/, "Exception has correct message" );
	}
	try {
		$f->delete( $sid );
	} catch( Text::Tradition::Error $e ) {
		is( $e->ident, 'database error', "Got exception trying to delete stemma directly" );
		like( $e->message, qr/Cannot directly delete non-Tradition object/, 
			"Exception has correct message" );
	}
	
	$f->delete( $uuid );
	ok( !$f->exists( $uuid ), "Object is deleted from DB" );
	ok( !$f->exists( $sid ), "Object stemma also deleted from DB" );
	is( scalar $f->traditionlist, 1, "Object is deleted from index" );
}

{
	my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
	my $scope = $g->new_scope;
	is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
	my $ntobj = $g->tradition( 'CX' );
	my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
	my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
	is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
}

=end testing

=cut

has +typemap => (
	is => 'rw',
	isa => 'KiokuDB::TypeMap',
	default => sub { 
		KiokuDB::TypeMap->new(
			isa_entries => {
				"Graph" => KiokuDB::TypeMap::Entry::Naive->new,
				"Graph::AdjacencyMap" => KiokuDB::TypeMap::Entry::Naive->new,
			}
		);
	},
);

# Push some columns into the extra_args
around BUILDARGS => sub {
	my $orig = shift;
	my $class = shift;
	my $args;
	if( @_ == 1 ) {
		$args = $_[0];
	} else {
		$args = { @_ };
	}
	if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
		my @column_args = ( 'columns',
			[ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 } ] );
		my $ea = $args->{'extra_args'};
		if( ref( $ea ) eq 'ARRAY' ) {
			push( @$ea, @column_args );
		} elsif( ref( $ea ) eq 'HASH' ) {
			$ea = { %$ea, @column_args };
		} else {
			$ea = { @column_args };
		}
		$args->{'extra_args'} = $ea;
	}
	return $class->$orig( $args );
};

before [ qw/ store update insert delete / ] => sub {
	my $self = shift;
	my @nontrad;
	foreach my $obj ( @_ ) {
#		if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition' ) {

		if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition'
            && ref ($obj) ne 'Text::Tradition::User' ) {
			# Is it an id => Tradition hash?
			if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
				my( $k ) = keys %$obj;
				next if ref( $obj->{$k} ) eq 'Text::Tradition';
			}
			push( @nontrad, $obj );
		}
	}
	if( @nontrad ) {
		throw( "Cannot directly save non-Tradition object of type "
			. ref( $nontrad[0] ) );
	}
};

# TODO Garbage collection doesn't work. Suck it up and live with the 
# inflated DB.
# after delete => sub {
# 	my $self = shift;
# 	my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
# 	$self->directory->backend->delete( $gc->garbage->members );
# };

sub save {
	my $self = shift;
	return $self->store( @_ );
}

sub tradition {
	my( $self, $id ) = @_;
	my $obj = $self->lookup( $id );
	unless( $obj ) {
		# Try looking up by name.
		foreach my $item ( $self->traditionlist ) {
			if( $item->{'name'} eq $id ) {
				$obj = $self->lookup( $item->{'id'} );
				last;
			}
		}
	}
	if( $obj && ref( $obj ) ne 'Text::Tradition' ) {
		throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
	}
	return $obj;
}

sub traditionlist {
	my $self = shift;
	# If we are using DBI, we can do it the easy way; if not, the hard way.
	# Easy way still involves making a separate DBI connection. Ew.
	my @tlist;
	if( $self->dsn =~ /^dbi:(\w+):/ ) {
		my $dbtype = $1;
		my @connection = @{$self->directory->backend->connect_info};
		# Get rid of KiokuDB-specific arg
		pop @connection if scalar @connection > 4;
		$connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
		$connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
		my $dbh = DBI->connect( @connection );
		my $q = $dbh->prepare( 'SELECT id, name from entries WHERE class = "Text::Tradition"' );
		$q->execute();
		while( my @row = $q->fetchrow_array ) {
			my( $id, $name ) = @row;
			# Horrible horrible hack
			$name = decode_utf8( $name ) if $dbtype eq 'mysql';
			push( @tlist, { 'id' => $row[0], 'name' => $row[1] } );
		}
	} else {
		$self->scan( sub { my $o = shift; 
						   push( @tlist, { 'id' => $self->object_to_id( $o ), 
										   'name' => $o->name } ) } );
	}
	return @tlist;
}

sub throw {
	Text::Tradition::Error->throw( 
		'ident' => 'database error',
		'message' => $_[0],
		);
}

=head1 NAME

Text::Tradition::UserStore - KiokuDB storage management for Users

=head1 SYNOPSIS

    my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
    my $newuser = $userstore->add_user({ username => 'fred',
                                         password => 'somepassword' });

    my $fetchuser = $userstore->find_user({ username => 'fred' });
    if($fetchuser->check_password('somepassword')) { 
       ## login user or .. whatever
    }

    my $user = $userstore->deactivate_user({ username => 'fred' });
    if(!$user->active) { 
      ## shouldnt be able to login etc
    }

=head1 DESCRIPTION

A L<KiokuX::Model> for managing the storage and creation of
L<Text::Tradition::User> objects. Subclass or replace this module in
order to use a different source for stemmaweb users.

=head2 ATTRIBUTES

=head3 dsn

Inherited from KiokuX::Model - dsn for the data store we are using. 

=head3 MIN_PASS_LEN

Constant for the minimum password length when validating passwords,
defaults to "8".

=cut

has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );

# has 'directory' => ( 
#     is => 'rw', 
#     isa => 'KiokuX::Model',
#     handles => []
#     );

## TODO: Some of these methods should probably optionally take $user objects
## instead of hashrefs.

## It also occurs to me that all these methods don't need to be named
## XX_user, but leaving that way for now incase we merge this code
## into ::Directory for one-store.

## To die or not to die, on error, this is the question.

=head2 METHODS

=head3 add_user

Takes a hashref of C<username>, C<password>.

Create a new user object, store in the KiokuDB backend, and return it.

=cut

sub add_user {
    my ($self, $userinfo) = @_;
    my $username = $userinfo->{url} || $userinfo->{username};
    my $password = $userinfo->{password};

    return unless ($username =~ /^https?:/ 
                   || ($username && $self->validate_password($password))) ;

    my $user = Text::Tradition::User->new(
        id => $username,
        password => ($password ? crypt_password($password) : ''),
    );

    my $scope = $self->new_scope;
    $self->store($user->kiokudb_object_id, $user);

    return $user;
}

sub create_user {
    my $self = shift;
    return $self->add_user(@_);
}

=head3 find_user

Takes a hashref of C<username>, optionally C<openid_identifier>.

Fetches the user object for the given username and returns it.

=cut

sub find_user {
    my ($self, $userinfo) = @_;
    ## url or display?
    # 'display' => 'castaway.myopenid.com',
    # 'url' => 'http://castaway.myopenid.com/',
    my $username = $userinfo->{url} || $userinfo->{username};

    return $self->lookup(Text::Tradition::User->id_for_user($username));
    
}

=head3 modify_user

Takes a hashref of C<username> and C<password> (same as add_user).

Retrieves the user, and updates it with the new information. Username
changing is not currently supported.

Returns the updated user object, or undef if not found.

=cut

sub modify_user {
    my ($self, $userinfo) = @_;
    my $username = $userinfo->{username};
    my $password = $userinfo->{password};

    return unless $username && $self->validate_password($password);

    my $scope = $self->new_scope;
    my $user = $self->find_user({ username => $username });
    return unless $user;

    $user->password(crypt_password($password));

    $self->update($user);

    return $user;
}

=head3 deactivate_user

Takes a hashref of C<username>.

Sets the users C<active> flag to false (0), and sets all traditions
assigned to them to non-public, updates the storage and returns the
deactivated user.

Returns undef if user not found.

=cut

sub deactivate_user {
    my ($self, $userinfo) = @_;
    my $username = $userinfo->{username};

    return if !$username;

    my $user = $self->find_user({ username => $username });
    return if !$user;

    $user->active(0);
    foreach my $tradition (@{ $user->traditions }) {
        ## Not implemented yet
        # $tradition->public(0);
    }
    my $scope = $self->new_scope;

    ## Should we be using Text::Tradition::Directory also?
    $self->update(@{ $user->traditions });

    $self->update($user);

    return $user;
}

=head3 reactivate_user

Takes a hashref of C<username>.

Returns the user object if already activated. Activates (sets the
active flag to true (1)), updates the storage and returns the user.

Returns undef if the user is not found.

=cut

sub reactivate_user {
    my ($self, $userinfo) = @_;
    my $username = $userinfo->{username};

    return if !$username;

    my $scope = $self->new_scope;
    my $user = $self->find_user({ username => $username });
    return if !$user;

    return $user if $user->active;

    $user->active(1);
    $self->update($user);

    return $user;    
}

=head3 delete_user

CAUTION: Delets actual data!

Takes a hashref of C<username>.

Returns undef if the user doesn't exist.

Removes the user from the store and returns 1.

=cut

sub delete_user {
    my ($self, $userinfo) = @_;
    my $username = $userinfo->{username};

    return if !$username;

    my $scope = $self->new_scope;
    my $user = $self->find_user({ username => $username });
    return if !$user;

    ## Should we be using Text::Tradition::Directory for this bit?
    $self->delete( @{ $user->traditions });

    ## Poof, gone.
    $self->delete($user);

    return 1;
}

=head3 validate_password

Takes a password string. Returns true if it is longer than
L</MIN_PASS_LEN>, false otherwise.

Used internally by L</add_user>.

=cut

sub validate_password {
    my ($self, $password) = @_;

    return if !$password;
    return if length($password) < $self->MIN_PASS_LEN;

    return 1;
}

1;
	
=head1 LICENSE

This package is free software and is provided "as is" without express
or implied warranty.  You can redistribute it and/or modify it under
the same terms as Perl itself.

=head1 AUTHOR

Tara L Andrews E<lt>aurum@cpan.orgE<gt>
Commit	Line	Data
8d9a1cd8	1	package Text::Tradition::Directory;
	2
	3	use strict;
	4	use warnings;
	5	use Moose;
98a6cab2	6	use DBI;
0a900793	7	use Encode qw/ decode_utf8 /;
ad1291ee	8	use KiokuDB::GC::Naive;
8d9a1cd8	9	use KiokuDB::TypeMap;
8d9a1cd8	10	use KiokuDB::TypeMap::Entry::Naive;
861c3e27	11	use Text::Tradition::Error;
8d9a1cd8	12
cf7e4e7b	13	## users
	14	use KiokuX::User::Util qw(crypt_password);
	15	use Text::Tradition::User;
	16
8d9a1cd8	17	extends 'KiokuX::Model';
8d9a1cd8	18
12523041	19	=head1 NAME
	20
	21	Text::Tradition::Directory - a KiokuDB interface for storing and retrieving traditions
	22
	23	=head1 SYNOPSIS
	24
	25	use Text::Tradition::Directory;
	26	my $d = Text::Tradition::Directory->new(
	27	'dsn' => 'dbi:SQLite:mytraditions.db',
	28	'extra_args' => { 'create' => 1 },
	29	);
	30
	31	my $tradition = Text::Tradition->new( @args );
9ba651b9	32	my $stemma = $tradition->add_stemma( dotfile => $dotfile );
12523041	33	$d->save_tradition( $tradition );
12523041	34
	35	foreach my $id ( $d->traditions ) {
	36	print $d->tradition( $id )->name;
12523041	37	}
	38
	39	=head1 DESCRIPTION
	40
	41	Text::Tradition::Directory is an interface for storing and retrieving text traditions and all their data, including an associated stemma hypothesis. It is an instantiation of a KiokuDB::Model, storing traditions and associated stemmas by UUID.
	42
	43	=head1 METHODS
	44
	45	=head2 new
	46
56cf65bd	47	Returns a Directory object.
12523041	48
98a6cab2	49	=head2 traditionlist
12523041	50
98a6cab2	51	Returns a hashref mapping of ID => name for all traditions in the directory.
12523041	52
	53	=head2 tradition( $id )
	54
	55	Returns the Text::Tradition object of the given ID.
	56
56cf65bd	57	=head2 save( $tradition )
12523041	58
56cf65bd	59	Writes the given tradition to the database, returning its ID.
12523041	60
d7ba60b4	61	=head2 delete( $tradition )
	62
	63	Deletes the given tradition object from the database.
	64	WARNING!! Garbage collection does not yet work. Use this sparingly.
	65
12523041	66	=begin testing
12523041	67
861c3e27	68	use TryCatch;
12523041	69	use File::Temp;
12523041	70	use Text::Tradition;
12523041	71	use_ok 'Text::Tradition::Directory';
	72
	73	my $fh = File::Temp->new();
	74	my $file = $fh->filename;
	75	$fh->close;
	76	my $dsn = "dbi:SQLite:dbname=$file";
861c3e27	77	my $uuid;
12523041	78	my $t = Text::Tradition->new(
56cf65bd	79	'name' => 'inline',
	80	'input' => 'Tabular',
	81	'file' => 't/data/simple.txt',
	82	);
56cf65bd	83
861c3e27	84	{
	85	my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
	86	'extra_args' => { 'create' => 1 } );
	87	is( ref $d, 'Text::Tradition::Directory', "Got directory object" );
	88
	89	my $scope = $d->new_scope;
	90	$uuid = $d->save( $t );
	91	ok( $uuid, "Saved test tradition" );
	92
9ba651b9	93	my $s = $t->add_stemma( dotfile => 't/data/simple.dot' );
861c3e27	94	ok( $d->save( $t ), "Updated tradition with stemma" );
861c3e27	95	is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" );
e0d617e6	96	is( $d->tradition( $uuid )->stemma(0), $s, "...and it has the correct stemma" );
861c3e27	97	try {
	98	$d->save( $s );
	99	} catch( Text::Tradition::Error $e ) {
	100	is( $e->ident, 'database error', "Got exception trying to save stemma directly" );
	101	like( $e->message, qr/Cannot directly save non-Tradition object/,
	102	"Exception has correct message" );
	103	}
	104	}
	105	my $nt = Text::Tradition->new(
	106	'name' => 'CX',
	107	'input' => 'CollateX',
	108	'file' => 't/data/Collatex-16.xml',
	109	);
	110	is( ref( $nt ), 'Text::Tradition', "Made new tradition" );
	111
	112	{
	113	my $f = Text::Tradition::Directory->new( 'dsn' => $dsn );
	114	my $scope = $f->new_scope;
98a6cab2	115	is( scalar $f->traditionlist, 1, "Directory index has our tradition" );
861c3e27	116	my $nuuid = $f->save( $nt );
861c3e27	117	ok( $nuuid, "Stored second tradition" );
98a6cab2	118	my @tlist = $f->traditionlist;
98a6cab2	119	is( scalar @tlist, 2, "Directory index has both traditions" );
861c3e27	120	my $tf = $f->tradition( $uuid );
98a6cab2	121	my( $tlobj ) = grep { $_->{'id'} eq $uuid } @tlist;
98a6cab2	122	is( $tlobj->{'name'}, $tf->name, "Directory index has correct tradition name" );
861c3e27	123	is( $tf->name, $t->name, "Retrieved the tradition from a new directory" );
e0d617e6	124	my $sid = $f->object_to_id( $tf->stemma(0) );
861c3e27	125	try {
	126	$f->tradition( $sid );
	127	} catch( Text::Tradition::Error $e ) {
	128	is( $e->ident, 'database error', "Got exception trying to fetch stemma directly" );
	129	like( $e->message, qr/not a Text::Tradition/, "Exception has correct message" );
	130	}
	131	try {
	132	$f->delete( $sid );
	133	} catch( Text::Tradition::Error $e ) {
	134	is( $e->ident, 'database error', "Got exception trying to delete stemma directly" );
	135	like( $e->message, qr/Cannot directly delete non-Tradition object/,
	136	"Exception has correct message" );
	137	}
ad39942e	138
861c3e27	139	$f->delete( $uuid );
	140	ok( !$f->exists( $uuid ), "Object is deleted from DB" );
	141	ok( !$f->exists( $sid ), "Object stemma also deleted from DB" );
98a6cab2	142	is( scalar $f->traditionlist, 1, "Object is deleted from index" );
861c3e27	143	}
861c3e27	144
d7ba60b4	145	{
861c3e27	146	my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
861c3e27	147	my $scope = $g->new_scope;
98a6cab2	148	is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
ad39942e	149	my $ntobj = $g->tradition( 'CX' );
09909f9d	150	my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
09909f9d	151	my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
ad39942e	152	is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
861c3e27	153	}
12523041	154
	155	=end testing
	156
	157	=cut
	158
12523041	159	has +typemap => (
8d9a1cd8	160	is => 'rw',
	161	isa => 'KiokuDB::TypeMap',
	162	default => sub {
	163	KiokuDB::TypeMap->new(
	164	isa_entries => {
8d9a1cd8	165	"Graph" => KiokuDB::TypeMap::Entry::Naive->new,
	166	"Graph::AdjacencyMap" => KiokuDB::TypeMap::Entry::Naive->new,
	167	}
	168	);
	169	},
	170	);
	171
98a6cab2	172	# Push some columns into the extra_args
	173	around BUILDARGS => sub {
	174	my $orig = shift;
	175	my $class = shift;
	176	my $args;
	177	if( @_ == 1 ) {
	178	$args = $_[0];
	179	} else {
	180	$args = { @_ };
	181	}
	182	if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
	183	my @column_args = ( 'columns',
	184	[ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 } ] );
	185	my $ea = $args->{'extra_args'};
	186	if( ref( $ea ) eq 'ARRAY' ) {
	187	push( @$ea, @column_args );
	188	} elsif( ref( $ea ) eq 'HASH' ) {
	189	$ea = { %$ea, @column_args };
	190	} else {
	191	$ea = { @column_args };
	192	}
	193	$args->{'extra_args'} = $ea;
	194	}
	195	return $class->$orig( $args );
	196	};
	197
861c3e27	198	before [ qw/ store update insert delete / ] => sub {
8d9a1cd8	199	my $self = shift;
861c3e27	200	my @nontrad;
861c3e27	201	foreach my $obj ( @_ ) {
cf7e4e7b	202	# if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition' ) {
	203
	204	if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition'
	205	&& ref ($obj) ne 'Text::Tradition::User' ) {
861c3e27	206	# Is it an id => Tradition hash?
	207	if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
	208	my( $k ) = keys %$obj;
	209	next if ref( $obj->{$k} ) eq 'Text::Tradition';
8d9a1cd8	210	}
861c3e27	211	push( @nontrad, $obj );
8d9a1cd8	212	}
12523041	213	}
861c3e27	214	if( @nontrad ) {
	215	throw( "Cannot directly save non-Tradition object of type "
	216	. ref( $nontrad[0] ) );
	217	}
	218	};
12523041	219
d7ba60b4	220	# TODO Garbage collection doesn't work. Suck it up and live with the
	221	# inflated DB.
	222	# after delete => sub {
	223	# my $self = shift;
	224	# my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
	225	# $self->directory->backend->delete( $gc->garbage->members );
	226	# };
56cf65bd	227
56cf65bd	228	sub save {
861c3e27	229	my $self = shift;
861c3e27	230	return $self->store( @_ );
12523041	231	}
12523041	232
56cf65bd	233	sub tradition {
	234	my( $self, $id ) = @_;
	235	my $obj = $self->lookup( $id );
ad39942e	236	unless( $obj ) {
	237	# Try looking up by name.
	238	foreach my $item ( $self->traditionlist ) {
	239	if( $item->{'name'} eq $id ) {
	240	$obj = $self->lookup( $item->{'id'} );
	241	last;
	242	}
	243	}
	244	}
	245	if( $obj && ref( $obj ) ne 'Text::Tradition' ) {
861c3e27	246	throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
12523041	247	}
56cf65bd	248	return $obj;
12523041	249	}
8d9a1cd8	250
98a6cab2	251	sub traditionlist {
861c3e27	252	my $self = shift;
98a6cab2	253	# If we are using DBI, we can do it the easy way; if not, the hard way.
	254	# Easy way still involves making a separate DBI connection. Ew.
	255	my @tlist;
0a900793	256	if( $self->dsn =~ /^dbi:(\w+):/ ) {
0a900793	257	my $dbtype = $1;
98a6cab2	258	my @connection = @{$self->directory->backend->connect_info};
	259	# Get rid of KiokuDB-specific arg
	260	pop @connection if scalar @connection > 4;
0a900793	261	$connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
0a900793	262	$connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
98a6cab2	263	my $dbh = DBI->connect( @connection );
	264	my $q = $dbh->prepare( 'SELECT id, name from entries WHERE class = "Text::Tradition"' );
	265	$q->execute();
	266	while( my @row = $q->fetchrow_array ) {
0a900793	267	my( $id, $name ) = @row;
	268	# Horrible horrible hack
	269	$name = decode_utf8( $name ) if $dbtype eq 'mysql';
98a6cab2	270	push( @tlist, { 'id' => $row[0], 'name' => $row[1] } );
	271	}
	272	} else {
	273	$self->scan( sub { my $o = shift;
	274	push( @tlist, { 'id' => $self->object_to_id( $o ),
	275	'name' => $o->name } ) } );
	276	}
	277	return @tlist;
861c3e27	278	}
	279
	280	sub throw {
	281	Text::Tradition::Error->throw(
	282	'ident' => 'database error',
	283	'message' => $_[0],
	284	);
	285	}
	286
cf7e4e7b	287	=head1 NAME
	288
	289	Text::Tradition::UserStore - KiokuDB storage management for Users
	290
	291	=head1 SYNOPSIS
	292
	293	my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
	294	my $newuser = $userstore->add_user({ username => 'fred',
	295	password => 'somepassword' });
	296
	297	my $fetchuser = $userstore->find_user({ username => 'fred' });
	298	if($fetchuser->check_password('somepassword')) {
	299	## login user or .. whatever
	300	}
	301
	302	my $user = $userstore->deactivate_user({ username => 'fred' });
	303	if(!$user->active) {
	304	## shouldnt be able to login etc
	305	}
	306
	307	=head1 DESCRIPTION
	308
	309	A L<KiokuX::Model> for managing the storage and creation of
	310	L<Text::Tradition::User> objects. Subclass or replace this module in
	311	order to use a different source for stemmaweb users.
	312
	313	=head2 ATTRIBUTES
	314
	315	=head3 dsn
	316
	317	Inherited from KiokuX::Model - dsn for the data store we are using.
	318
	319	=head3 MIN_PASS_LEN
	320
	321	Constant for the minimum password length when validating passwords,
	322	defaults to "8".
	323
	324	=cut
	325
	326	has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
	327
	328	# has 'directory' => (
	329	# is => 'rw',
	330	# isa => 'KiokuX::Model',
	331	# handles => []
	332	# );
	333
	334	## TODO: Some of these methods should probably optionally take $user objects
	335	## instead of hashrefs.
	336
	337	## It also occurs to me that all these methods don't need to be named
	338	## XX_user, but leaving that way for now incase we merge this code
	339	## into ::Directory for one-store.
	340
	341	## To die or not to die, on error, this is the question.
	342
	343	=head2 METHODS
	344
	345	=head3 add_user
	346
	347	Takes a hashref of C<username>, C<password>.
	348
	349	Create a new user object, store in the KiokuDB backend, and return it.
	350
351	=cut
352
353	sub add_user {
354	my ($self, $userinfo) = @_;
355	my $username = $userinfo->{url} \|\| $userinfo->{username};
356	my $password = $userinfo->{password};
357
358	return unless ($username =~ /^https?:/
359	\|\| ($username && $self->validate_password($password))) ;
360
361	my $user = Text::Tradition::User->new(
362	id => $username,
363	password => ($password ? crypt_password($password) : ''),
364	);
365
366	my $scope = $self->new_scope;
367	$self->store($user->kiokudb_object_id, $user);
368
369	return $user;
370	}
371
372	sub create_user {
373	my $self = shift;
374	return $self->add_user(@_);
375	}
376
377	=head3 find_user
378
379	Takes a hashref of C<username>, optionally C<openid_identifier>.
380
381	Fetches the user object for the given username and returns it.
382
383	=cut
384
385	sub find_user {
386	my ($self, $userinfo) = @_;
387	## url or display?
388	# 'display' => 'castaway.myopenid.com',
389	# 'url' => 'http://castaway.myopenid.com/',
390	my $username = $userinfo->{url} \|\| $userinfo->{username};
391
392	return $self->lookup(Text::Tradition::User->id_for_user($username));
393
394	}
395
396	=head3 modify_user
397
398	Takes a hashref of C<username> and C<password> (same as add_user).
399
400	Retrieves the user, and updates it with the new information. Username
401	changing is not currently supported.
402
403	Returns the updated user object, or undef if not found.
404
405	=cut
406
407	sub modify_user {
408	my ($self, $userinfo) = @_;
409	my $username = $userinfo->{username};
410	my $password = $userinfo->{password};
411
412	return unless $username && $self->validate_password($password);
413
414	my $scope = $self->new_scope;
415	my $user = $self->find_user({ username => $username });
416	return unless $user;
417
418	$user->password(crypt_password($password));
419
420	$self->update($user);
421
422	return $user;
423	}
424
425	=head3 deactivate_user
426
427	Takes a hashref of C<username>.
428
429	Sets the users C<active> flag to false (0), and sets all traditions
430	assigned to them to non-public, updates the storage and returns the
431	deactivated user.
432
433	Returns undef if user not found.
434
435	=cut
436
437	sub deactivate_user {
438	my ($self, $userinfo) = @_;
439	my $username = $userinfo->{username};
440
441	return if !$username;
442
443	my $user = $self->find_user({ username => $username });
444	return if !$user;
445
446	$user->active(0);
447	foreach my $tradition (@{ $user->traditions }) {
448	## Not implemented yet
449	# $tradition->public(0);
450	}
451	my $scope = $self->new_scope;
452
453	## Should we be using Text::Tradition::Directory also?
454	$self->update(@{ $user->traditions });
455
456	$self->update($user);
457
458	return $user;
459	}
460
461	=head3 reactivate_user
462
463	Takes a hashref of C<username>.
464
465	Returns the user object if already activated. Activates (sets the
466	active flag to true (1)), updates the storage and returns the user.
467
468	Returns undef if the user is not found.
469
470	=cut
471
472	sub reactivate_user {
473	my ($self, $userinfo) = @_;
474	my $username = $userinfo->{username};
475
476	return if !$username;
477
478	my $scope = $self->new_scope;
479	my $user = $self->find_user({ username => $username });
480	return if !$user;
481
482	return $user if $user->active;
483
484	$user->active(1);
485	$self->update($user);
486
487	return $user;
488	}
489
490	=head3 delete_user
491
492	CAUTION: Delets actual data!
493
494	Takes a hashref of C<username>.
495
496	Returns undef if the user doesn't exist.
497
498	Removes the user from the store and returns 1.
499
500	=cut
501
502	sub delete_user {
503	my ($self, $userinfo) = @_;
504	my $username = $userinfo->{username};
505
506	return if !$username;
507
508	my $scope = $self->new_scope;
509	my $user = $self->find_user({ username => $username });
510	return if !$user;
511
512	## Should we be using Text::Tradition::Directory for this bit?
513	$self->delete( @{ $user->traditions });
514
515	## Poof, gone.
516	$self->delete($user);
517
518	return 1;
519	}
520
521	=head3 validate_password
522
523	Takes a password string. Returns true if it is longer than
524	L</MIN_PASS_LEN>, false otherwise.
525
526	Used internally by L</add_user>.
527
528	=cut
529
530	sub validate_password {
531	my ($self, $password) = @_;
532
533	return if !$password;
534	return if length($password) < $self->MIN_PASS_LEN;
535
536	return 1;
537	}
538
8d9a1cd8	539	1;
12523041	540
027d819c	541	=head1 LICENSE
	542
	543	This package is free software and is provided "as is" without express
	544	or implied warranty. You can redistribute it and/or modify it under
	545	the same terms as Perl itself.
	546
	547	=head1 AUTHOR
	548
	549	Tara L Andrews E<lt>aurum@cpan.orgE<gt>