[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;
  }

  ## Users:
  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

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 ATTRIBUTES

=head2 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 } );

=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 );
};

## These checks don't cover store($id, $obj)
before [ qw/ store update insert delete / ] => sub {
	my $self = shift;
	my @nontrad;
	foreach my $obj ( @_ ) {
		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 user_traditionlist {
    my ($self, $user) = @_;

    my @tlist;
    if(ref $user && $user->is_admin) {
        ## Admin sees all
        return $self->traditionlist();
    } elsif(ref $user) {
        ## We have a user object already, so just fetch its traditions and use tose
        foreach my $t (@{ $user->traditions }) {
            push( @tlist, { 'id' => $self->object_to_id( $t ), 
                            'name' => $t->name } );
        }
        return @tlist;
    } elsif($user ne 'public') {
        die "Passed neither a user object nor 'public' to user_traditionlist";
    }
    
    ## Search for all traditions which allow public viewing
    ## When they exist!
## This needs to be more sophisticated, probably needs Search::GIN
#    my $list = $self->search({ public => 1 });
    
    ## For now, just fetch all
    ## (could use all_objects or grep down there?)
    return $self->traditionlist();
}

sub traditionlist {
	my $self = shift;
    my ($user) = @_;

    return $self->user_traditionlist($user) if($user);

	my @tlist;
	# 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.
	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],
		);
}


# 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 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};
    my $role = $userinfo->{role} || 'user';

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

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

    $self->store($user->kiokudb_object_id, $user);

    return $user;
}

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

=head2 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};

    ## No logins if user is deactivated (use lookup to fetch to re-activate)
    my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
    return if($user && !$user->active);

    return $user;
    
}

=head2 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};
    my $role = $userinfo->{role};

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

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

    if($password) {
        $user->password(crypt_password($password));
    }
    if($role) {
        $user->role($role);
    }

    $self->update($user);

    return $user;
}

=head2 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);
    }

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

    $self->update($user);

    return $user;
}

=head2 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 $user = $self->lookup(Text::Tradition::User->id_for_user($username));
    return if !$user;

    return $user if $user->active;

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

    return $user;    
}

=head2 delete_user

CAUTION: Deletes 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 $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;
}

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