1 package Text::Tradition::Directory;
7 use Encode qw/ encode 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';
22 use vars qw/ $VERSION /;
27 Text::Tradition::Directory - a KiokuDB interface for storing and retrieving
28 traditions and their owners
32 use Text::Tradition::Directory;
33 my $d = Text::Tradition::Directory->new(
34 'dsn' => 'dbi:SQLite:mytraditions.db',
35 'extra_args' => { 'create' => 1 },
38 my $tradition = Text::Tradition->new( @args );
39 my $stemma = $tradition->add_stemma( dotfile => $dotfile ); # if Analysis module installed
40 $d->save_tradition( $tradition );
42 foreach my $id ( $d->traditions ) {
43 print $d->tradition( $id )->name;
47 my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
48 my $newuser = $userstore->add_user({ username => 'fred',
49 password => 'somepassword' });
51 my $fetchuser = $userstore->find_user({ username => 'fred' });
52 if($fetchuser->check_password('somepassword')) {
53 ## login user or .. whatever
56 my $user = $userstore->deactivate_user({ username => 'fred' });
58 ## shouldnt be able to login etc
63 Text::Tradition::Directory is an interface for storing and retrieving text
64 traditions and all their data, including an associated stemma hypothesis
65 and a user who has ownership rights to the tradition data. It is an
66 instantiation of a KiokuDB::Model, storing traditions and associated
69 The Text::Tradition::Directory package also includes the
70 L<Text::Tradition::User> class for user objects, and the
71 L<Text::Tradition::Ownership> role which extends the Text::Tradition class
72 to handle user ownership.
78 Constant for the minimum password length when validating passwords,
83 has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
89 Returns a Directory object.
93 Returns a hashref mapping of ID => name for all traditions in the directory.
95 =head2 tradition( $id )
97 Returns the Text::Tradition object of the given ID.
99 =head2 save( $tradition )
101 Writes the given tradition to the database, returning its ID.
103 =head2 delete( $tradition )
105 Deletes the given tradition object from the database.
106 WARNING!! Garbage collection does not yet work. Use this sparingly.
114 use_ok 'Text::Tradition::Directory';
116 my $fh = File::Temp->new();
117 my $file = $fh->filename;
119 my $dsn = "dbi:SQLite:dbname=$file";
121 my $user = 'user@example.org';
122 my $t = Text::Tradition->new(
124 'input' => 'Tabular',
125 'file' => 't/data/simple.txt',
127 my $stemma_enabled = $t->can( 'add_stemma' );
130 my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
131 'extra_args' => { 'create' => 1 } );
132 ok( $d->$_isa('Text::Tradition::Directory'), "Got directory object" );
134 my $scope = $d->new_scope;
135 $uuid = $d->save( $t );
136 ok( $uuid, "Saved test tradition" );
139 my $user = $d->add_user({ username => $user, password => 'UserPass' });
140 $user->add_tradition( $t );
142 is( $t->user, $user, "Assigned tradition to test user" );
145 skip "Analysis package not installed", 5 unless $stemma_enabled;
146 my $s = $t->add_stemma( dotfile => 't/data/simple.dot' );
147 ok( $d->save( $t ), "Updated tradition with stemma" );
148 is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" );
149 is( $d->tradition( $uuid )->stemma(0), $s, "...and it has the correct stemma" );
152 } catch( Text::Tradition::Error $e ) {
153 is( $e->ident, 'database error', "Got exception trying to save stemma directly" );
154 like( $e->message, qr/Cannot directly save non-Tradition object/,
155 "Exception has correct message" );
159 my $nt = Text::Tradition->new(
161 'input' => 'CollateX',
162 'file' => 't/data/Collatex-16.xml',
164 ok( $nt->$_isa('Text::Tradition'), "Made new tradition" );
167 my $f = Text::Tradition::Directory->new( 'dsn' => $dsn );
168 my $scope = $f->new_scope;
169 is( scalar $f->traditionlist, 1, "Directory index has our tradition" );
170 my $nuuid = $f->save( $nt );
171 ok( $nuuid, "Stored second tradition" );
172 my @tlist = $f->traditionlist;
173 is( scalar @tlist, 2, "Directory index has both traditions" );
174 my $tf = $f->tradition( $uuid );
175 my( $tlobj ) = grep { $_->{'id'} eq $uuid } @tlist;
176 is( $tlobj->{'name'}, $tf->name, "Directory index has correct tradition name" );
177 is( $tf->name, $t->name, "Retrieved the tradition from a new directory" );
180 skip "Analysis package not installed", 4 unless $stemma_enabled;
181 $sid = $f->object_to_id( $tf->stemma(0) );
183 $f->tradition( $sid );
184 } catch( Text::Tradition::Error $e ) {
185 is( $e->ident, 'database error', "Got exception trying to fetch stemma directly" );
186 like( $e->message, qr/not a Text::Tradition/, "Exception has correct message" );
190 } catch( Text::Tradition::Error $e ) {
191 is( $e->ident, 'database error', "Got exception trying to delete stemma directly" );
192 like( $e->message, qr/Cannot directly delete non-Tradition object/,
193 "Exception has correct message" );
198 ok( !$f->exists( $uuid ), "Object is deleted from DB" );
199 ok( !$f->exists( $sid ), "Object stemma also deleted from DB" ) if $stemma_enabled;
200 is( scalar $f->traditionlist, 1, "Object is deleted from index" );
204 my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
205 my $scope = $g->new_scope;
206 is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
207 my $ntobj = $g->tradition( 'CX' );
208 my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
209 my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
210 is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
216 use Text::Tradition::TypeMap::Entry;
220 isa => 'KiokuDB::TypeMap',
222 KiokuDB::TypeMap->new(
224 # now that we fall back to YAML deflation, all attributes of
225 # Text::Tradition will be serialized to YAML as individual objects
226 # Except if we declare a specific entry type here
228 KiokuDB::TypeMap::Entry::MOP->new(),
229 # We need users to be naive entries so that they hold
230 # references to the original tradition objects, not clones
231 "Text::Tradition::User" =>
232 KiokuDB::TypeMap::Entry::MOP->new(),
233 "Text::Tradition::Collation" =>
234 KiokuDB::TypeMap::Entry::MOP->new(),
235 "Text::Tradition::Witness" =>
236 KiokuDB::TypeMap::Entry::MOP->new(),
237 "Graph" => Text::Tradition::TypeMap::Entry->new(),
238 "Set::Scalar" => Text::Tradition::TypeMap::Entry->new(),
244 has '_mysql_utf8_hack' => (
250 # Push some columns into the extra_args
251 around BUILDARGS => sub {
261 if( $args->{'dsn'} =~ /^dbi:(\w+):/ ) { # We're using Backend::DBI
263 @column_args = ( 'columns',
264 [ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 },
265 'public' => { 'data_type' => 'bool', 'is_nullable' => 1 } ] );
266 if( $dbtype eq 'mysql' &&
267 exists $args->{extra_args}->{dbi_attrs} &&
268 $args->{extra_args}->{dbi_attrs}->{mysql_enable_utf8} ) {
269 # There is a bad interaction with MySQL in utf-8 mode.
270 # Work around it here.
271 # TODO fix the underlying storage problem
272 $args->{extra_args}->{dbi_attrs}->{mysql_enable_utf8} = undef;
273 $args->{_mysql_utf8_hack} = 1;
276 my $ea = $args->{'extra_args'};
277 if( ref( $ea ) eq 'ARRAY' ) {
278 push( @$ea, @column_args );
279 } elsif( ref( $ea ) eq 'HASH' ) {
280 $ea = { %$ea, @column_args };
282 $ea = { @column_args };
284 $args->{'extra_args'} = $ea;
286 return $class->$orig( $args );
289 override _build_directory => sub {
291 Text::Tradition::Store->connect(@{ $self->_connect_args },
292 resolver_constructor => sub {
294 $class->new({ typemap => $self->directory->merged_typemap,
295 fallback_entry => Text::Tradition::TypeMap::Entry->new() });
299 ## These checks don't cover store($id, $obj)
300 # before [ qw/ store update insert delete / ] => sub {
301 before [ qw/ delete / ] => sub {
304 foreach my $obj ( @_ ) {
305 if( ref( $obj ) && !$obj->$_isa( 'Text::Tradition' )
306 && !$obj->$_isa('Text::Tradition::User') ) {
307 # Is it an id => Tradition hash?
308 if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
309 my( $k ) = keys %$obj;
310 next if $obj->{$k}->$_isa('Text::Tradition');
312 push( @nontrad, $obj );
316 throw( "Cannot directly save non-Tradition object of type "
317 . ref( $nontrad[0] ) );
321 # TODO Garbage collection doesn't work. Suck it up and live with the
323 after delete => sub {
325 my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
326 $self->directory->backend->delete( $gc->garbage->members );
331 return $self->store( @_ );
335 my( $self, $id ) = @_;
336 my $obj = $self->lookup( $id );
338 # Try looking up by name.
339 foreach my $item ( $self->traditionlist ) {
340 if( $item->{'name'} eq $id ) {
341 $obj = $self->lookup( $item->{'id'} );
346 if( $obj && !$obj->$_isa('Text::Tradition') ) {
347 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
356 return $self->user_traditionlist($user) if($user);
357 return $self->_get_object_idlist( 'Text::Tradition' );
360 sub _get_object_idlist {
361 my( $self, $objclass ) = @_;
363 # If we are using DBI, we can do it the easy way; if not, the hard way.
364 # Easy way still involves making a separate DBI connection. Ew.
365 if( $self->dsn =~ /^dbi:(\w+):/ ) {
367 my @connection = @{$self->directory->backend->connect_info};
368 # Get rid of KiokuDB-specific arg
369 pop @connection if scalar @connection > 4;
370 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
371 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
372 my $dbh = DBI->connect( @connection );
373 my $q = $dbh->prepare( 'SELECT id, name, public from entries WHERE class = "'
376 while( my @row = $q->fetchrow_array ) {
377 # Horrible horrible hack. Re-convert the name to UTF-8.
378 if( $self->_mysql_utf8_hack ) {
379 # Convert the chars into a raw bytestring.
380 my $octets = encode( 'ISO-8859-1', $row[1] );
381 $row[1] = decode_utf8( $octets );
383 push( @tlist, { 'id' => $row[0], 'name' => $row[1], 'public' => $row[2] } );
386 $self->scan( sub { my $o = shift;
387 push( @tlist, { 'id' => $self->object_to_id( $o ),
389 'public' => $o->public } )
390 if( ref $o eq $objclass ) } );
396 Text::Tradition::Error->throw(
397 'ident' => 'database error',
403 # has 'directory' => (
405 # isa => 'KiokuX::Model',
409 ## TODO: Some of these methods should probably optionally take $user objects
410 ## instead of hashrefs.
412 ## It also occurs to me that all these methods don't need to be named
413 ## XX_user, but leaving that way for now incase we merge this code
414 ## into ::Directory for one-store.
416 =head1 USER DIRECTORY METHODS
418 =head2 add_user( $userinfo )
420 Takes a hashref of C<username>, C<password>.
422 Create a new user object, store in the KiokuDB backend, and return it.
427 my ($self, $userinfo) = @_;
429 my $username = $userinfo->{username};
430 my $password = $userinfo->{password};
431 my $role = $userinfo->{role} || 'user';
433 throw( "No username given" ) unless $username;
434 throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
435 . " characters long" )
436 unless ( $self->validate_password($password) || $username =~ /^https?:/ );
438 my $user = Text::Tradition::User->new(
440 password => ($password ? crypt_password($password) : ''),
441 email => ($userinfo->{email} ? $userinfo->{email} : $username),
445 $self->store($user->kiokudb_object_id, $user);
450 =head2 create_user( $userinfo )
452 Takes a hashref that can either be suitable for add_user (see above) or be
453 a hash of OpenID user information from Credential::OpenID.
458 my ($self, $userinfo) = @_;
460 ## No username means probably an OpenID based user
461 if(!exists $userinfo->{username}) {
462 _extract_openid_data($userinfo);
465 return $self->add_user($userinfo);
468 ## Not quite sure where this method should be.. Auth /
469 ## Credential::OpenID just pass us back the chunk of extension data
470 sub _extract_openid_data {
473 ## Spec says SHOULD use url as identifier
474 $userinfo->{username} = $userinfo->{url};
476 ## Use email addy as display if available
477 if(exists $userinfo->{extensions} &&
478 exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
479 defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
480 ## Somewhat ugly attribute extension reponse, contains
481 ## google-email string which we can use as the id
483 $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
489 =head2 find_user( $userinfo )
491 Takes a hashref of C<username> or C<email>, and possibly openIDish results from
492 L<Net::OpenID::Consumer>.
494 Fetches the user object for the given username and returns it.
499 my ($self, $userinfo) = @_;
501 ## A URL field means probably an OpenID based user
502 if( exists $userinfo->{url} ) {
503 _extract_openid_data($userinfo);
507 if( exists $userinfo->{username} ) {
508 my $username = $userinfo->{username};
509 ## No logins if user is deactivated (use lookup to fetch to re-activate)
510 $user = $self->lookup(Text::Tradition::User->id_for_user($username));
511 ## If there is an inactive user, skip it
512 return if( $user && !$user->active );
513 } elsif( exists $userinfo->{email} ) {
514 ## Scan the users looking for a matching email
516 $self->scan( sub { push( @matches, @_ )
517 if $_[0]->isa('Text::Tradition::User')
518 && $_[0]->email eq $userinfo->{email} } );
519 $user = shift @matches;
521 # print STDERR "Found user, $username, email is :", $user->email, ":\n";
525 =head2 modify_user( $userinfo )
527 Takes a hashref of C<username> and C<password> (same as add_user).
529 Retrieves the user, and updates it with the new information. Username
530 changing is not currently supported.
532 Returns the updated user object, or undef if not found.
537 my ($self, $userinfo) = @_;
538 my $username = $userinfo->{username};
539 my $password = $userinfo->{password};
540 my $role = $userinfo->{role};
542 throw( "Missing username" ) unless $username;
544 my $user = $self->find_user({ username => $username });
545 throw( "Could not find user $username" ) unless $user;
548 throw( "Bad password" ) unless $self->validate_password($password);
549 $user->password(crypt_password($password));
555 $self->update($user);
560 =head2 deactivate_user( $userinfo )
562 Takes a hashref of C<username>.
564 Sets the users C<active> flag to false (0), and sets all traditions
565 assigned to them to non-public, updates the storage and returns the
568 Returns undef if user not found.
572 sub deactivate_user {
573 my ($self, $userinfo) = @_;
574 my $username = $userinfo->{username};
576 throw( "Need to specify a username for deactivation" ) unless $username;
578 my $user = $self->find_user({ username => $username });
579 throw( "User $username not found" ) unless $user;
582 foreach my $tradition (@{ $user->traditions }) {
583 ## Not implemented yet
584 # $tradition->public(0);
587 ## Should we be using Text::Tradition::Directory also?
588 $self->update(@{ $user->traditions });
590 $self->update($user);
595 =head2 reactivate_user( $userinfo )
597 Takes a hashref of C<username>.
599 Returns the user object if already activated. Activates (sets the
600 active flag to true (1)), updates the storage and returns the user.
602 Returns undef if the user is not found.
606 sub reactivate_user {
607 my ($self, $userinfo) = @_;
608 my $username = $userinfo->{username};
610 throw( "Need to specify a username for reactivation" ) unless $username;
612 my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
613 throw( "User $username not found" ) unless $user;
615 return $user if $user->active;
618 $self->update($user);
623 =head2 delete_user( $userinfo )
625 CAUTION: Deletes actual data!
627 Takes a hashref of C<username>.
629 Returns undef if the user doesn't exist.
631 Removes the user from the store and returns 1.
636 my ($self, $userinfo) = @_;
637 my $username = $userinfo->{username};
639 throw( "Need to specify a username for deletion" ) unless $username;
641 my $user = $self->find_user({ username => $username });
642 throw( "User $username not found" ) unless $user;
644 ## Should we be using Text::Tradition::Directory for this bit?
645 $self->delete( @{ $user->traditions });
648 $self->delete($user);
653 =head2 validate_password( $password )
655 Takes a password string. Returns true if it is longer than
656 L</MIN_PASS_LEN>, false otherwise.
658 Used internally by L</add_user>.
662 sub validate_password {
663 my ($self, $password) = @_;
665 return if !$password;
666 return if length($password) < $self->MIN_PASS_LEN;
671 =head2 user_traditionlist( $user )
673 Returns a tradition list (see specification above) but containing only
674 those traditions visible to the specified user. If $user is the string
675 'public', returns only publicly-viewable traditions.
679 sub user_traditionlist {
680 my ($self, $user) = @_;
683 if(ref $user && $user->is_admin) {
685 return $self->traditionlist();
687 ## We have a user object already, so just fetch its traditions and use tose
688 foreach my $t (@{ $user->traditions }) {
689 push( @tlist, { 'id' => $self->object_to_id( $t ),
690 'name' => $t->name } );
693 } elsif($user ne 'public') {
694 die "Passed neither a user object nor 'public' to user_traditionlist";
697 ## Search for all traditions which allow public viewing
698 my @list = grep { $_->{public} } $self->traditionlist();
706 This package is free software and is provided "as is" without express
707 or implied warranty. You can redistribute it and/or modify it under
708 the same terms as Perl itself.
712 Tara L Andrews E<lt>aurum@cpan.orgE<gt> (initial release)
714 Shadowcat Systems L<http://www.scsys.co.uk/> (user functionality; making it all work)