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

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 => {
	# now that we fall back to YAML deflation, all attributes of
	# Text::Tradition will be serialized to YAML as individual objects
	# Except if we declare a specific entry type here
        "Text::Tradition" =>
          KiokuDB::TypeMap::Entry::MOP->new(),
	# We need users to be naive entries so that they hold
	# references to the original tradition objects, not clones
        "Text::Tradition::User" =>
          KiokuDB::TypeMap::Entry::MOP->new(),
        "Text::Tradition::Collation" =>
          KiokuDB::TypeMap::Entry::MOP->new(),
        "Text::Tradition::Witness" =>
          KiokuDB::TypeMap::Entry::MOP->new(),
        "Graph" => 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 = { @_ };
	}
	my @column_args;
	if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
		@column_args = ( 'columns',
			[ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 },
			  'public' => { 'data_type' => 'bool', '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 );
};

override _build_directory => sub {
  my($self) = @_;
  Text::Tradition::Store->connect(@{ $self->_connect_args },
    resolver_constructor => sub {
      my($class) = @_;
      $class->new({ typemap => $self->directory->merged_typemap,
                    fallback_entry => Text::Tradition::TypeMap::Entry->new() });
  });
};

## 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
	my @list = grep { $_->{public} } $self->traditionlist();
	return @list;
}

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, public 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], 'public' => $row[2] } );
		}
	} else {
		$self->scan( sub { my $o = shift; 
						   push( @tlist, { 'id' => $self->object_to_id( $o ), 
										   'name' => $o->name,
										   'public' => $o->public } ) } );
	}
	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" ) unless $username;

    my $user = $self->find_user({ username => $username });
    throw( "Could not find user $username" ) unless $user;

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