[scpubgit/stemmatology.git] / base / 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 Safe::Isa;
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 );
  $tradition->enable_stemmata;
  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 Safe::Isa;
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 $stemma_enabled;
eval { $stemma_enabled = $t->enable_stemmata; };

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