[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
use Text::Tradition::TypeMap::Entry;

has +typemap => (
  is      => 'rw',
  isa     => 'KiokuDB::TypeMap',
  default => sub {
    KiokuDB::TypeMap->new(
      isa_entries => {
        "Text::Tradition" =>
          Text::Tradition::TypeMap::Entry->new(),
        "Graph" => Text::Tradition::TypeMap::Entry->new(),
        "Graph::AdjacencyMap" => Text::Tradition::TypeMap::Entry->new(),
        "Set::Scalar" => Text::Tradition::TypeMap::Entry->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 {
before [ qw/ 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->{username};
    my $password = $userinfo->{password};
    my $role = $userinfo->{role} || 'user';

	throw( "No username given" ) unless $username;
	throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN 
		. " characters long" )
		unless ( $self->validate_password($password) || $username =~ /^https?:/ );

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

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

    return $user;
}

sub create_user {
    my ($self, $userinfo) = @_;

    ## No username means probably an OpenID based user
    if(!exists $userinfo->{username}) {
        extract_openid_data($userinfo);
    }

    return $self->add_user($userinfo);
}

## Not quite sure where this method should be.. Auth /
## Credential::OpenID just pass us back the chunk of extension data
sub extract_openid_data {
    my ($userinfo) = @_;

    ## Spec says SHOULD use url as identifier
    $userinfo->{username} = $userinfo->{url};

    ## Use email addy as display if available
    if(exists $userinfo->{extensions} &&
         exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
         defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
        ## Somewhat ugly attribute extension reponse, contains
        ## google-email string which we can use as the id

        $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
    }

    return;
}

=head2 find_user

Takes a hashref of C<username>, and possibly openIDish results from
L<Net::OpenID::Consumer>.

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

=cut

sub find_user {
    my ($self, $userinfo) = @_;

    ## No username means probably an OpenID based user
    if(!exists $userinfo->{username}) {
        extract_openid_data($userinfo);
    }

    my $username = $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);

#    print STDERR "Found user, $username, email is :", $user->email, ":\n";

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

    throw( "Missing username or bad password" )
    	unless $username && $self->validate_password($password);

    my $user = $self->find_user({ username => $username });
    throw( "Could not find user $username" ) 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};

    throw( "Need to specify a username for deactivation" ) unless $username;

    my $user = $self->find_user({ username => $username });
    throw( "User $username not found" ) unless $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};

    throw( "Need to specify a username for reactivation" ) unless $username;

    my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
    throw( "User $username not found" ) unless $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};

    throw( "Need to specify a username for deletion" ) unless $username;

    my $user = $self->find_user({ username => $username });
    throw( "User $username not found" ) unless $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
fc7b6388	184	use Text::Tradition::TypeMap::Entry;
12523041	185
12523041	186	has +typemap => (
fc7b6388	187	is => 'rw',
	188	isa => 'KiokuDB::TypeMap',
	189	default => sub {
	190	KiokuDB::TypeMap->new(
	191	isa_entries => {
	192	"Text::Tradition" =>
3be63d24	193	Text::Tradition::TypeMap::Entry->new(),
fc7b6388	194	"Graph" => Text::Tradition::TypeMap::Entry->new(),
fc7b6388	195	"Graph::AdjacencyMap" => Text::Tradition::TypeMap::Entry->new(),
7e17346f	196	"Set::Scalar" => Text::Tradition::TypeMap::Entry->new(),
fc7b6388	197	}
	198	);
	199	},
8d9a1cd8	200	);
8d9a1cd8	201
98a6cab2	202	# Push some columns into the extra_args
	203	around BUILDARGS => sub {
	204	my $orig = shift;
	205	my $class = shift;
	206	my $args;
	207	if( @_ == 1 ) {
	208	$args = $_[0];
	209	} else {
	210	$args = { @_ };
	211	}
	212	if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
	213	my @column_args = ( 'columns',
	214	[ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 } ] );
	215	my $ea = $args->{'extra_args'};
	216	if( ref( $ea ) eq 'ARRAY' ) {
	217	push( @$ea, @column_args );
	218	} elsif( ref( $ea ) eq 'HASH' ) {
	219	$ea = { %$ea, @column_args };
	220	} else {
	221	$ea = { @column_args };
	222	}
	223	$args->{'extra_args'} = $ea;
	224	}
	225	return $class->$orig( $args );
	226	};
	227
7cb56251	228	## These checks don't cover store($id, $obj)
fc7b6388	229	# before [ qw/ store update insert delete / ] => sub {
fc7b6388	230	before [ qw/ delete / ] => sub {
8d9a1cd8	231	my $self = shift;
861c3e27	232	my @nontrad;
861c3e27	233	foreach my $obj ( @_ ) {
cf7e4e7b	234	if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition'
cf7e4e7b	235	&& ref ($obj) ne 'Text::Tradition::User' ) {
861c3e27	236	# Is it an id => Tradition hash?
	237	if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
	238	my( $k ) = keys %$obj;
	239	next if ref( $obj->{$k} ) eq 'Text::Tradition';
8d9a1cd8	240	}
861c3e27	241	push( @nontrad, $obj );
8d9a1cd8	242	}
12523041	243	}
861c3e27	244	if( @nontrad ) {
	245	throw( "Cannot directly save non-Tradition object of type "
	246	. ref( $nontrad[0] ) );
	247	}
	248	};
12523041	249
d7ba60b4	250	# TODO Garbage collection doesn't work. Suck it up and live with the
d7ba60b4	251	# inflated DB.
d94224d9	252	after delete => sub {
	253	my $self = shift;
	254	my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
	255	$self->directory->backend->delete( $gc->garbage->members );
	256	};
56cf65bd	257
56cf65bd	258	sub save {
861c3e27	259	my $self = shift;
861c3e27	260	return $self->store( @_ );
12523041	261	}
12523041	262
56cf65bd	263	sub tradition {
	264	my( $self, $id ) = @_;
	265	my $obj = $self->lookup( $id );
ad39942e	266	unless( $obj ) {
	267	# Try looking up by name.
	268	foreach my $item ( $self->traditionlist ) {
	269	if( $item->{'name'} eq $id ) {
	270	$obj = $self->lookup( $item->{'id'} );
	271	last;
	272	}
	273	}
	274	}
	275	if( $obj && ref( $obj ) ne 'Text::Tradition' ) {
861c3e27	276	throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
12523041	277	}
56cf65bd	278	return $obj;
12523041	279	}
8d9a1cd8	280
fefeeeda	281	sub user_traditionlist {
	282	my ($self, $user) = @_;
	283
	284	my @tlist;
7cb56251	285	if(ref $user && $user->is_admin) {
	286	## Admin sees all
	287	return $self->traditionlist();
	288	} elsif(ref $user) {
fefeeeda	289	## We have a user object already, so just fetch its traditions and use tose
7d52d62b	290	foreach my $t (@{ $user->traditions }) {
fefeeeda	291	push( @tlist, { 'id' => $self->object_to_id( $t ),
	292	'name' => $t->name } );
	293	}
	294	return @tlist;
7d52d62b	295	} elsif($user ne 'public') {
7d52d62b	296	die "Passed neither a user object nor 'public' to user_traditionlist";
fefeeeda	297	}
	298
	299	## Search for all traditions which allow public viewing
	300	## When they exist!
3724dfa7	301	## This needs to be more sophisticated, probably needs Search::GIN
3724dfa7	302	# my $list = $self->search({ public => 1 });
fefeeeda	303
	304	## For now, just fetch all
	305	## (could use all_objects or grep down there?)
	306	return $self->traditionlist();
	307	}
	308
98a6cab2	309	sub traditionlist {
861c3e27	310	my $self = shift;
fefeeeda	311	my ($user) = @_;
	312
	313	return $self->user_traditionlist($user) if($user);
	314
	315	my @tlist;
98a6cab2	316	# If we are using DBI, we can do it the easy way; if not, the hard way.
98a6cab2	317	# Easy way still involves making a separate DBI connection. Ew.
0a900793	318	if( $self->dsn =~ /^dbi:(\w+):/ ) {
0a900793	319	my $dbtype = $1;
98a6cab2	320	my @connection = @{$self->directory->backend->connect_info};
	321	# Get rid of KiokuDB-specific arg
	322	pop @connection if scalar @connection > 4;
0a900793	323	$connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
0a900793	324	$connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
98a6cab2	325	my $dbh = DBI->connect( @connection );
	326	my $q = $dbh->prepare( 'SELECT id, name from entries WHERE class = "Text::Tradition"' );
	327	$q->execute();
	328	while( my @row = $q->fetchrow_array ) {
0a900793	329	my( $id, $name ) = @row;
	330	# Horrible horrible hack
	331	$name = decode_utf8( $name ) if $dbtype eq 'mysql';
98a6cab2	332	push( @tlist, { 'id' => $row[0], 'name' => $row[1] } );
	333	}
	334	} else {
	335	$self->scan( sub { my $o = shift;
	336	push( @tlist, { 'id' => $self->object_to_id( $o ),
	337	'name' => $o->name } ) } );
	338	}
	339	return @tlist;
861c3e27	340	}
	341
	342	sub throw {
	343	Text::Tradition::Error->throw(
	344	'ident' => 'database error',
	345	'message' => $_[0],
	346	);
	347	}
	348
cf7e4e7b	349
	350	# has 'directory' => (
	351	# is => 'rw',
	352	# isa => 'KiokuX::Model',
	353	# handles => []
	354	# );
	355
	356	## TODO: Some of these methods should probably optionally take $user objects
	357	## instead of hashrefs.
	358
	359	## It also occurs to me that all these methods don't need to be named
	360	## XX_user, but leaving that way for now incase we merge this code
	361	## into ::Directory for one-store.
	362
	363	## To die or not to die, on error, this is the question.
	364
770f7a2b	365	=head2 add_user
cf7e4e7b	366
	367	Takes a hashref of C<username>, C<password>.
	368
	369	Create a new user object, store in the KiokuDB backend, and return it.
	370
	371	=cut
	372
	373	sub add_user {
	374	my ($self, $userinfo) = @_;
10ef7653	375
10ef7653	376	my $username = $userinfo->{username};
cf7e4e7b	377	my $password = $userinfo->{password};
7cb56251	378	my $role = $userinfo->{role} \|\| 'user';
cf7e4e7b	379
b77f6c1b	380	throw( "No username given" ) unless $username;
	381	throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
	382	. " characters long" )
	383	unless ( $self->validate_password($password) \|\| $username =~ /^https?:/ );
cf7e4e7b	384
	385	my $user = Text::Tradition::User->new(
	386	id => $username,
	387	password => ($password ? crypt_password($password) : ''),
a528f0f6	388	email => ($userinfo->{email} ? $userinfo->{email} : $username),
7cb56251	389	role => $role,
cf7e4e7b	390	);
cf7e4e7b	391
cf7e4e7b	392	$self->store($user->kiokudb_object_id, $user);
	393
	394	return $user;
	395	}
	396
	397	sub create_user {
10ef7653	398	my ($self, $userinfo) = @_;
	399
	400	## No username means probably an OpenID based user
	401	if(!exists $userinfo->{username}) {
	402	extract_openid_data($userinfo);
	403	}
	404
	405	return $self->add_user($userinfo);
	406	}
	407
	408	## Not quite sure where this method should be.. Auth /
	409	## Credential::OpenID just pass us back the chunk of extension data
	410	sub extract_openid_data {
	411	my ($userinfo) = @_;
	412
	413	## Spec says SHOULD use url as identifier
	414	$userinfo->{username} = $userinfo->{url};
	415
	416	## Use email addy as display if available
	417	if(exists $userinfo->{extensions} &&
	418	exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
	419	defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
	420	## Somewhat ugly attribute extension reponse, contains
	421	## google-email string which we can use as the id
	422
a528f0f6	423	$userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
10ef7653	424	}
	425
	426	return;
cf7e4e7b	427	}
cf7e4e7b	428
770f7a2b	429	=head2 find_user
cf7e4e7b	430
10ef7653	431	Takes a hashref of C<username>, and possibly openIDish results from
10ef7653	432	L<Net::OpenID::Consumer>.
cf7e4e7b	433
	434	Fetches the user object for the given username and returns it.
	435
	436	=cut
	437
	438	sub find_user {
	439	my ($self, $userinfo) = @_;
10ef7653	440
	441	## No username means probably an OpenID based user
	442	if(!exists $userinfo->{username}) {
	443	extract_openid_data($userinfo);
	444	}
	445
	446	my $username = $userinfo->{username};
cf7e4e7b	447
df8c12f0	448	## No logins if user is deactivated (use lookup to fetch to re-activate)
df8c12f0	449	my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
10ef7653	450	return if(!$user \|\| !$user->active);
10ef7653	451
c80a73ea	452	# print STDERR "Found user, $username, email is :", $user->email, ":\n";
df8c12f0	453
df8c12f0	454	return $user;
cf7e4e7b	455	}
cf7e4e7b	456
770f7a2b	457	=head2 modify_user
cf7e4e7b	458
	459	Takes a hashref of C<username> and C<password> (same as add_user).
	460
	461	Retrieves the user, and updates it with the new information. Username
	462	changing is not currently supported.
	463
	464	Returns the updated user object, or undef if not found.
	465
	466	=cut
	467
	468	sub modify_user {
	469	my ($self, $userinfo) = @_;
	470	my $username = $userinfo->{username};
	471	my $password = $userinfo->{password};
4d4c5789	472	my $role = $userinfo->{role};
cf7e4e7b	473
b77f6c1b	474	throw( "Missing username or bad password" )
b77f6c1b	475	unless $username && $self->validate_password($password);
cf7e4e7b	476
cf7e4e7b	477	my $user = $self->find_user({ username => $username });
b77f6c1b	478	throw( "Could not find user $username" ) unless $user;
cf7e4e7b	479
4d4c5789	480	if($password) {
	481	$user->password(crypt_password($password));
	482	}
	483	if($role) {
	484	$user->role($role);
	485	}
cf7e4e7b	486
	487	$self->update($user);
	488
	489	return $user;
	490	}
	491
770f7a2b	492	=head2 deactivate_user
cf7e4e7b	493
	494	Takes a hashref of C<username>.
	495
	496	Sets the users C<active> flag to false (0), and sets all traditions
	497	assigned to them to non-public, updates the storage and returns the
	498	deactivated user.
	499
	500	Returns undef if user not found.
	501
	502	=cut
	503
	504	sub deactivate_user {
	505	my ($self, $userinfo) = @_;
	506	my $username = $userinfo->{username};
	507
b77f6c1b	508	throw( "Need to specify a username for deactivation" ) unless $username;
cf7e4e7b	509
cf7e4e7b	510	my $user = $self->find_user({ username => $username });
b77f6c1b	511	throw( "User $username not found" ) unless $user;
cf7e4e7b	512
	513	$user->active(0);
	514	foreach my $tradition (@{ $user->traditions }) {
	515	## Not implemented yet
	516	# $tradition->public(0);
	517	}
cf7e4e7b	518
	519	## Should we be using Text::Tradition::Directory also?
	520	$self->update(@{ $user->traditions });
	521
	522	$self->update($user);
	523
	524	return $user;
	525	}
	526
770f7a2b	527	=head2 reactivate_user
cf7e4e7b	528
	529	Takes a hashref of C<username>.
	530
	531	Returns the user object if already activated. Activates (sets the
	532	active flag to true (1)), updates the storage and returns the user.
	533
	534	Returns undef if the user is not found.
	535
	536	=cut
	537
	538	sub reactivate_user {
	539	my ($self, $userinfo) = @_;
	540	my $username = $userinfo->{username};
	541
b77f6c1b	542	throw( "Need to specify a username for reactivation" ) unless $username;
cf7e4e7b	543
df8c12f0	544	my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
b77f6c1b	545	throw( "User $username not found" ) unless $user;
cf7e4e7b	546
	547	return $user if $user->active;
	548
	549	$user->active(1);
	550	$self->update($user);
	551
	552	return $user;
	553	}
	554
770f7a2b	555	=head2 delete_user
cf7e4e7b	556
770f7a2b	557	CAUTION: Deletes actual data!
cf7e4e7b	558
	559	Takes a hashref of C<username>.
	560
	561	Returns undef if the user doesn't exist.
	562
	563	Removes the user from the store and returns 1.
	564
	565	=cut
	566
	567	sub delete_user {
	568	my ($self, $userinfo) = @_;
	569	my $username = $userinfo->{username};
	570
b77f6c1b	571	throw( "Need to specify a username for deletion" ) unless $username;
cf7e4e7b	572
cf7e4e7b	573	my $user = $self->find_user({ username => $username });
b77f6c1b	574	throw( "User $username not found" ) unless $user;
cf7e4e7b	575
	576	## Should we be using Text::Tradition::Directory for this bit?
	577	$self->delete( @{ $user->traditions });
	578
	579	## Poof, gone.
	580	$self->delete($user);
	581
	582	return 1;
	583	}
	584
770f7a2b	585	=head2 validate_password
cf7e4e7b	586
	587	Takes a password string. Returns true if it is longer than
	588	L</MIN_PASS_LEN>, false otherwise.
	589
	590	Used internally by L</add_user>.
	591
	592	=cut
	593
	594	sub validate_password {
	595	my ($self, $password) = @_;
	596
	597	return if !$password;
	598	return if length($password) < $self->MIN_PASS_LEN;
	599
	600	return 1;
	601	}
	602
8d9a1cd8	603	1;
12523041	604
027d819c	605	=head1 LICENSE
	606
	607	This package is free software and is provided "as is" without express
	608	or implied warranty. You can redistribute it and/or modify it under
	609	the same terms as Perl itself.
	610
	611	=head1 AUTHOR
	612
	613	Tara L Andrews E<lt>aurum@cpan.orgE<gt>