1 package Text::Tradition::Directory;
7 use Encode qw/ decode_utf8 /;
8 use KiokuDB::GC::Naive;
10 use KiokuDB::TypeMap::Entry::Naive;
12 use Text::Tradition::Error;
15 use KiokuX::User::Util qw(crypt_password);
16 use Text::Tradition::Store;
17 use Text::Tradition::User;
18 use Text::Tradition::TypeMap::Entry;
20 extends 'KiokuX::Model';
24 Text::Tradition::Directory - a KiokuDB interface for storing and retrieving traditions
28 use Text::Tradition::Directory;
29 my $d = Text::Tradition::Directory->new(
30 'dsn' => 'dbi:SQLite:mytraditions.db',
31 'extra_args' => { 'create' => 1 },
34 my $tradition = Text::Tradition->new( @args );
35 my $stemma = $tradition->add_stemma( dotfile => $dotfile ); # if Analysis module installed
36 $d->save_tradition( $tradition );
38 foreach my $id ( $d->traditions ) {
39 print $d->tradition( $id )->name;
43 my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
44 my $newuser = $userstore->add_user({ username => 'fred',
45 password => 'somepassword' });
47 my $fetchuser = $userstore->find_user({ username => 'fred' });
48 if($fetchuser->check_password('somepassword')) {
49 ## login user or .. whatever
52 my $user = $userstore->deactivate_user({ username => 'fred' });
54 ## shouldnt be able to login etc
59 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.
65 Constant for the minimum password length when validating passwords,
70 has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
76 Returns a Directory object.
80 Returns a hashref mapping of ID => name for all traditions in the directory.
82 =head2 tradition( $id )
84 Returns the Text::Tradition object of the given ID.
86 =head2 save( $tradition )
88 Writes the given tradition to the database, returning its ID.
90 =head2 delete( $tradition )
92 Deletes the given tradition object from the database.
93 WARNING!! Garbage collection does not yet work. Use this sparingly.
101 use_ok 'Text::Tradition::Directory';
103 my $fh = File::Temp->new();
104 my $file = $fh->filename;
106 my $dsn = "dbi:SQLite:dbname=$file";
108 my $t = Text::Tradition->new(
110 'input' => 'Tabular',
111 'file' => 't/data/simple.txt',
113 my $stemma_enabled = $t->can( 'add_stemma' );
116 my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
117 'extra_args' => { 'create' => 1 } );
118 ok( $d->$_isa('Text::Tradition::Directory'), "Got directory object" );
120 my $scope = $d->new_scope;
121 $uuid = $d->save( $t );
122 ok( $uuid, "Saved test tradition" );
125 skip "Analysis package not installed", 5 unless $stemma_enabled;
126 my $s = $t->add_stemma( dotfile => 't/data/simple.dot' );
127 ok( $d->save( $t ), "Updated tradition with stemma" );
128 is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" );
129 is( $d->tradition( $uuid )->stemma(0), $s, "...and it has the correct stemma" );
132 } catch( Text::Tradition::Error $e ) {
133 is( $e->ident, 'database error', "Got exception trying to save stemma directly" );
134 like( $e->message, qr/Cannot directly save non-Tradition object/,
135 "Exception has correct message" );
139 my $nt = Text::Tradition->new(
141 'input' => 'CollateX',
142 'file' => 't/data/Collatex-16.xml',
144 ok( $nt->$_isa('Text::Tradition'), "Made new tradition" );
147 my $f = Text::Tradition::Directory->new( 'dsn' => $dsn );
148 my $scope = $f->new_scope;
149 is( scalar $f->traditionlist, 1, "Directory index has our tradition" );
150 my $nuuid = $f->save( $nt );
151 ok( $nuuid, "Stored second tradition" );
152 my @tlist = $f->traditionlist;
153 is( scalar @tlist, 2, "Directory index has both traditions" );
154 my $tf = $f->tradition( $uuid );
155 my( $tlobj ) = grep { $_->{'id'} eq $uuid } @tlist;
156 is( $tlobj->{'name'}, $tf->name, "Directory index has correct tradition name" );
157 is( $tf->name, $t->name, "Retrieved the tradition from a new directory" );
160 skip "Analysis package not installed", 4 unless $stemma_enabled;
161 $sid = $f->object_to_id( $tf->stemma(0) );
163 $f->tradition( $sid );
164 } catch( Text::Tradition::Error $e ) {
165 is( $e->ident, 'database error', "Got exception trying to fetch stemma directly" );
166 like( $e->message, qr/not a Text::Tradition/, "Exception has correct message" );
170 } catch( Text::Tradition::Error $e ) {
171 is( $e->ident, 'database error', "Got exception trying to delete stemma directly" );
172 like( $e->message, qr/Cannot directly delete non-Tradition object/,
173 "Exception has correct message" );
178 ok( !$f->exists( $uuid ), "Object is deleted from DB" );
179 ok( !$f->exists( $sid ), "Object stemma also deleted from DB" ) if $stemma_enabled;
180 is( scalar $f->traditionlist, 1, "Object is deleted from index" );
184 my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
185 my $scope = $g->new_scope;
186 is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
187 my $ntobj = $g->tradition( 'CX' );
188 my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
189 my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
190 is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
196 use Text::Tradition::TypeMap::Entry;
200 isa => 'KiokuDB::TypeMap',
202 KiokuDB::TypeMap->new(
204 # now that we fall back to YAML deflation, all attributes of
205 # Text::Tradition will be serialized to YAML as individual objects
206 # Except if we declare a specific entry type here
208 KiokuDB::TypeMap::Entry::MOP->new(),
209 # We need users to be naive entries so that they hold
210 # references to the original tradition objects, not clones
211 "Text::Tradition::User" =>
212 KiokuDB::TypeMap::Entry::MOP->new(),
213 "Text::Tradition::Collation" =>
214 KiokuDB::TypeMap::Entry::MOP->new(),
215 "Text::Tradition::Witness" =>
216 KiokuDB::TypeMap::Entry::MOP->new(),
217 "Graph" => Text::Tradition::TypeMap::Entry->new(),
218 "Set::Scalar" => Text::Tradition::TypeMap::Entry->new(),
224 # Push some columns into the extra_args
225 around BUILDARGS => sub {
235 if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
236 @column_args = ( 'columns',
237 [ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 },
238 'public' => { 'data_type' => 'bool', 'is_nullable' => 1 } ] );
240 my $ea = $args->{'extra_args'};
241 if( ref( $ea ) eq 'ARRAY' ) {
242 push( @$ea, @column_args );
243 } elsif( ref( $ea ) eq 'HASH' ) {
244 $ea = { %$ea, @column_args };
246 $ea = { @column_args };
248 $args->{'extra_args'} = $ea;
250 return $class->$orig( $args );
253 override _build_directory => sub {
255 Text::Tradition::Store->connect(@{ $self->_connect_args },
256 resolver_constructor => sub {
258 $class->new({ typemap => $self->directory->merged_typemap,
259 fallback_entry => Text::Tradition::TypeMap::Entry->new() });
263 ## These checks don't cover store($id, $obj)
264 # before [ qw/ store update insert delete / ] => sub {
265 before [ qw/ delete / ] => sub {
268 foreach my $obj ( @_ ) {
269 if( ref( $obj ) && !$obj->$_isa( 'Text::Tradition' )
270 && !$obj->$_isa('Text::Tradition::User') ) {
271 # Is it an id => Tradition hash?
272 if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
273 my( $k ) = keys %$obj;
274 next if $obj->{$k}->$_isa('Text::Tradition');
276 push( @nontrad, $obj );
280 throw( "Cannot directly save non-Tradition object of type "
281 . ref( $nontrad[0] ) );
285 # TODO Garbage collection doesn't work. Suck it up and live with the
287 after delete => sub {
289 my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
290 $self->directory->backend->delete( $gc->garbage->members );
295 return $self->store( @_ );
299 my( $self, $id ) = @_;
300 my $obj = $self->lookup( $id );
302 # Try looking up by name.
303 foreach my $item ( $self->traditionlist ) {
304 if( $item->{'name'} eq $id ) {
305 $obj = $self->lookup( $item->{'id'} );
310 if( $obj && !$obj->$_isa('Text::Tradition') ) {
311 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
320 return $self->user_traditionlist($user) if($user);
323 # If we are using DBI, we can do it the easy way; if not, the hard way.
324 # Easy way still involves making a separate DBI connection. Ew.
325 if( $self->dsn =~ /^dbi:(\w+):/ ) {
327 my @connection = @{$self->directory->backend->connect_info};
328 # Get rid of KiokuDB-specific arg
329 pop @connection if scalar @connection > 4;
330 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
331 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
332 my $dbh = DBI->connect( @connection );
333 my $q = $dbh->prepare( 'SELECT id, name, public from entries WHERE class = "Text::Tradition"' );
335 while( my @row = $q->fetchrow_array ) {
336 my( $id, $name ) = @row;
337 # Horrible horrible hack
338 $name = decode_utf8( $name ) if $dbtype eq 'mysql';
339 push( @tlist, { 'id' => $row[0], 'name' => $row[1], 'public' => $row[2] } );
342 $self->scan( sub { my $o = shift;
343 push( @tlist, { 'id' => $self->object_to_id( $o ),
345 'public' => $o->public } ) } );
351 Text::Tradition::Error->throw(
352 'ident' => 'database error',
358 # has 'directory' => (
360 # isa => 'KiokuX::Model',
364 ## TODO: Some of these methods should probably optionally take $user objects
365 ## instead of hashrefs.
367 ## It also occurs to me that all these methods don't need to be named
368 ## XX_user, but leaving that way for now incase we merge this code
369 ## into ::Directory for one-store.
371 =head1 USER DIRECTORY METHODS
373 =head2 add_user( $userinfo )
375 Takes a hashref of C<username>, C<password>.
377 Create a new user object, store in the KiokuDB backend, and return it.
382 my ($self, $userinfo) = @_;
384 my $username = $userinfo->{username};
385 my $password = $userinfo->{password};
386 my $role = $userinfo->{role} || 'user';
388 throw( "No username given" ) unless $username;
389 throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
390 . " characters long" )
391 unless ( $self->validate_password($password) || $username =~ /^https?:/ );
393 my $user = Text::Tradition::User->new(
395 password => ($password ? crypt_password($password) : ''),
396 email => ($userinfo->{email} ? $userinfo->{email} : $username),
400 $self->store($user->kiokudb_object_id, $user);
405 =head2 create_user( $userinfo )
407 Takes a hashref that can either be suitable for add_user (see above) or be
408 a hash of OpenID user information from Credential::OpenID.
413 my ($self, $userinfo) = @_;
415 ## No username means probably an OpenID based user
416 if(!exists $userinfo->{username}) {
417 _extract_openid_data($userinfo);
420 return $self->add_user($userinfo);
423 ## Not quite sure where this method should be.. Auth /
424 ## Credential::OpenID just pass us back the chunk of extension data
425 sub _extract_openid_data {
428 ## Spec says SHOULD use url as identifier
429 $userinfo->{username} = $userinfo->{url};
431 ## Use email addy as display if available
432 if(exists $userinfo->{extensions} &&
433 exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
434 defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
435 ## Somewhat ugly attribute extension reponse, contains
436 ## google-email string which we can use as the id
438 $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
444 =head2 find_user( $userinfo )
446 Takes a hashref of C<username>, and possibly openIDish results from
447 L<Net::OpenID::Consumer>.
449 Fetches the user object for the given username and returns it.
454 my ($self, $userinfo) = @_;
456 ## No username means probably an OpenID based user
457 if(!exists $userinfo->{username}) {
458 _extract_openid_data($userinfo);
461 my $username = $userinfo->{username};
463 ## No logins if user is deactivated (use lookup to fetch to re-activate)
464 my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
465 return if(!$user || !$user->active);
467 # print STDERR "Found user, $username, email is :", $user->email, ":\n";
472 =head2 modify_user( $userinfo )
474 Takes a hashref of C<username> and C<password> (same as add_user).
476 Retrieves the user, and updates it with the new information. Username
477 changing is not currently supported.
479 Returns the updated user object, or undef if not found.
484 my ($self, $userinfo) = @_;
485 my $username = $userinfo->{username};
486 my $password = $userinfo->{password};
487 my $role = $userinfo->{role};
489 throw( "Missing username" ) unless $username;
491 my $user = $self->find_user({ username => $username });
492 throw( "Could not find user $username" ) unless $user;
495 throw( "Bad password" ) unless $self->validate_password($password);
496 $user->password(crypt_password($password));
502 $self->update($user);
507 =head2 deactivate_user( $userinfo )
509 Takes a hashref of C<username>.
511 Sets the users C<active> flag to false (0), and sets all traditions
512 assigned to them to non-public, updates the storage and returns the
515 Returns undef if user not found.
519 sub deactivate_user {
520 my ($self, $userinfo) = @_;
521 my $username = $userinfo->{username};
523 throw( "Need to specify a username for deactivation" ) unless $username;
525 my $user = $self->find_user({ username => $username });
526 throw( "User $username not found" ) unless $user;
529 foreach my $tradition (@{ $user->traditions }) {
530 ## Not implemented yet
531 # $tradition->public(0);
534 ## Should we be using Text::Tradition::Directory also?
535 $self->update(@{ $user->traditions });
537 $self->update($user);
542 =head2 reactivate_user( $userinfo )
544 Takes a hashref of C<username>.
546 Returns the user object if already activated. Activates (sets the
547 active flag to true (1)), updates the storage and returns the user.
549 Returns undef if the user is not found.
553 sub reactivate_user {
554 my ($self, $userinfo) = @_;
555 my $username = $userinfo->{username};
557 throw( "Need to specify a username for reactivation" ) unless $username;
559 my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
560 throw( "User $username not found" ) unless $user;
562 return $user if $user->active;
565 $self->update($user);
570 =head2 delete_user( $userinfo )
572 CAUTION: Deletes actual data!
574 Takes a hashref of C<username>.
576 Returns undef if the user doesn't exist.
578 Removes the user from the store and returns 1.
583 my ($self, $userinfo) = @_;
584 my $username = $userinfo->{username};
586 throw( "Need to specify a username for deletion" ) unless $username;
588 my $user = $self->find_user({ username => $username });
589 throw( "User $username not found" ) unless $user;
591 ## Should we be using Text::Tradition::Directory for this bit?
592 $self->delete( @{ $user->traditions });
595 $self->delete($user);
600 =head2 validate_password( $password )
602 Takes a password string. Returns true if it is longer than
603 L</MIN_PASS_LEN>, false otherwise.
605 Used internally by L</add_user>.
609 sub validate_password {
610 my ($self, $password) = @_;
612 return if !$password;
613 return if length($password) < $self->MIN_PASS_LEN;
618 =head2 user_traditionlist( $user )
620 Returns a tradition list (see specification above) but containing only
621 those traditions visible to the specified user. If $user is the string
622 'public', returns only publicly-viewable traditions.
626 sub user_traditionlist {
627 my ($self, $user) = @_;
630 if(ref $user && $user->is_admin) {
632 return $self->traditionlist();
634 ## We have a user object already, so just fetch its traditions and use tose
635 foreach my $t (@{ $user->traditions }) {
636 push( @tlist, { 'id' => $self->object_to_id( $t ),
637 'name' => $t->name } );
640 } elsif($user ne 'public') {
641 die "Passed neither a user object nor 'public' to user_traditionlist";
644 ## Search for all traditions which allow public viewing
645 my @list = grep { $_->{public} } $self->traditionlist();
653 This package is free software and is provided "as is" without express
654 or implied warranty. You can redistribute it and/or modify it under
655 the same terms as Perl itself.
659 Tara L Andrews E<lt>aurum@cpan.orgE<gt>