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" );
188 if( $ENV{TEST_DELETION} ) {
191 } catch( Text::Tradition::Error $e ) {
192 is( $e->ident, 'database error', "Got exception trying to delete stemma directly" );
193 like( $e->message, qr/Cannot directly delete non-Tradition object/,
194 "Exception has correct message" );
200 skip "Set TEST_DELETION in env to test DB deletion functionality", 3
201 unless $ENV{TEST_DELETION};
203 ok( !$f->exists( $uuid ), "Object is deleted from DB" );
204 ok( !$f->exists( $sid ), "Object stemma also deleted from DB" ) if $stemma_enabled;
205 is( scalar $f->traditionlist, 1, "Object is deleted from index" );
210 my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
211 my $scope = $g->new_scope;
213 skip "Set TEST_DELETION in env to test DB deletion functionality", 1
214 unless $ENV{TEST_DELETION};
215 is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
217 my $ntobj = $g->tradition( 'CX' );
218 my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
219 my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
220 is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
226 use Text::Tradition::TypeMap::Entry;
230 isa => 'KiokuDB::TypeMap',
232 KiokuDB::TypeMap->new(
234 # now that we fall back to YAML deflation, all attributes of
235 # Text::Tradition will be serialized to YAML as individual objects
236 # Except if we declare a specific entry type here
238 KiokuDB::TypeMap::Entry::MOP->new(),
239 # We need users to be naive entries so that they hold
240 # references to the original tradition objects, not clones
241 "Text::Tradition::User" =>
242 KiokuDB::TypeMap::Entry::MOP->new(),
243 "Text::Tradition::Collation" =>
244 KiokuDB::TypeMap::Entry::MOP->new(),
245 "Text::Tradition::Witness" =>
246 KiokuDB::TypeMap::Entry::MOP->new(),
247 "Graph" => Text::Tradition::TypeMap::Entry->new(),
248 "Set::Scalar" => Text::Tradition::TypeMap::Entry->new(),
254 has '_mysql_utf8_hack' => (
260 # Push some columns into the extra_args
261 around BUILDARGS => sub {
271 if( $args->{'dsn'} =~ /^dbi:(\w+):/ ) { # We're using Backend::DBI
273 @column_args = ( 'columns',
274 [ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 },
275 'public' => { 'data_type' => 'bool', 'is_nullable' => 1 } ] );
276 if( $dbtype eq 'mysql' &&
277 exists $args->{extra_args}->{dbi_attrs} &&
278 $args->{extra_args}->{dbi_attrs}->{mysql_enable_utf8} ) {
279 # There is a bad interaction with MySQL in utf-8 mode.
280 # Work around it here.
281 # TODO fix the underlying storage problem
282 $args->{extra_args}->{dbi_attrs}->{mysql_enable_utf8} = undef;
283 $args->{_mysql_utf8_hack} = 1;
286 my $ea = $args->{'extra_args'};
287 if( ref( $ea ) eq 'ARRAY' ) {
288 push( @$ea, @column_args );
289 } elsif( ref( $ea ) eq 'HASH' ) {
290 $ea = { %$ea, @column_args };
292 $ea = { @column_args };
294 $args->{'extra_args'} = $ea;
296 return $class->$orig( $args );
299 override _build_directory => sub {
301 Text::Tradition::Store->connect(@{ $self->_connect_args },
302 resolver_constructor => sub {
304 $class->new({ typemap => $self->directory->merged_typemap,
305 fallback_entry => Text::Tradition::TypeMap::Entry->new() });
309 ## These checks don't cover store($id, $obj)
310 # before [ qw/ store update insert delete / ] => sub {
311 before [ qw/ delete / ] => sub {
314 foreach my $obj ( @_ ) {
315 if( ref( $obj ) && !$obj->$_isa( 'Text::Tradition' )
316 && !$obj->$_isa('Text::Tradition::User') ) {
317 # Is it an id => Tradition hash?
318 if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
319 my( $k ) = keys %$obj;
320 next if $obj->{$k}->$_isa('Text::Tradition');
322 push( @nontrad, $obj );
326 throw( "Cannot directly save non-Tradition object of type "
327 . ref( $nontrad[0] ) );
331 # TODO Garbage collection doesn't work. Suck it up and live with the
333 after delete => sub {
335 my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
336 $self->directory->backend->delete( $gc->garbage->members );
341 return $self->store( @_ );
345 my( $self, $id ) = @_;
346 my $obj = $self->lookup( $id );
348 # Try looking up by name.
349 foreach my $item ( $self->traditionlist ) {
350 if( $item->{'name'} eq $id ) {
351 $obj = $self->lookup( $item->{'id'} );
356 if( $obj && !$obj->$_isa('Text::Tradition') ) {
357 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
366 return $self->user_traditionlist($user) if($user);
367 return $self->_get_object_idlist( 'Text::Tradition' );
370 sub _get_object_idlist {
371 my( $self, $objclass ) = @_;
373 # If we are using DBI, we can do it the easy way; if not, the hard way.
374 # Easy way still involves making a separate DBI connection. Ew.
375 if( $self->dsn =~ /^dbi:(\w+):/ ) {
377 my @connection = @{$self->directory->backend->connect_info};
378 # Get rid of KiokuDB-specific arg
379 pop @connection if scalar @connection > 4;
380 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
381 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
382 my $dbh = DBI->connect( @connection );
383 my $q = $dbh->prepare( 'SELECT id, name, public from entries WHERE class = "'
386 while( my @row = $q->fetchrow_array ) {
387 # Horrible horrible hack. Re-convert the name to UTF-8.
388 if( $self->_mysql_utf8_hack ) {
389 # Convert the chars into a raw bytestring.
390 my $octets = encode( 'ISO-8859-1', $row[1] );
391 $row[1] = decode_utf8( $octets );
393 push( @tlist, { 'id' => $row[0], 'name' => $row[1], 'public' => $row[2] } );
396 $self->scan( sub { my $o = shift;
397 push( @tlist, { 'id' => $self->object_to_id( $o ),
399 'public' => $o->public } )
400 if( ref $o eq $objclass ) } );
406 Text::Tradition::Error->throw(
407 'ident' => 'database error',
413 # has 'directory' => (
415 # isa => 'KiokuX::Model',
419 ## TODO: Some of these methods should probably optionally take $user objects
420 ## instead of hashrefs.
422 ## It also occurs to me that all these methods don't need to be named
423 ## XX_user, but leaving that way for now incase we merge this code
424 ## into ::Directory for one-store.
426 =head1 USER DIRECTORY METHODS
428 =head2 add_user( $userinfo )
430 Takes a hashref of C<username>, C<password>.
432 Create a new user object, store in the KiokuDB backend, and return it.
437 my ($self, $userinfo) = @_;
439 my $username = $userinfo->{username};
440 my $password = $userinfo->{password};
441 my $role = $userinfo->{role} || 'user';
443 if ($userinfo->{sub}) {
444 $username = $userinfo->{sub};
447 throw( "No username given" ) unless $username;
448 throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
449 . " characters long" )
450 unless ( $self->validate_password($password) || $username =~ /^https?:/ || exists ($userinfo->{openid_id}) || exists ($userinfo->{sub}));
452 my $user = Text::Tradition::User->new(
454 password => ($password ? crypt_password($password) : ''),
455 email => ($userinfo->{email} ? $userinfo->{email} : $username),
459 $self->store($user->kiokudb_object_id, $user);
464 =head2 create_user( $userinfo )
466 Takes a hashref that can either be suitable for add_user (see above) or be
467 a hash of OpenID user information from Credential::OpenID.
472 my ($self, $userinfo) = @_;
474 ## No username means probably an OpenID based user
475 if(!exists $userinfo->{username}) {
476 _extract_openid_data($userinfo);
479 return $self->add_user($userinfo);
482 ## Not quite sure where this method should be.. Auth /
483 ## Credential::OpenID just pass us back the chunk of extension data
484 sub _extract_openid_data {
487 ## Spec says SHOULD use url as identifier
488 $userinfo->{username} = $userinfo->{url};
490 ## Use email addy as display if available
491 if(exists $userinfo->{extensions} &&
492 exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
493 defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
494 ## Somewhat ugly attribute extension reponse, contains
495 ## google-email string which we can use as the id
497 $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
503 =head2 find_user( $userinfo )
505 Takes a hashref of C<username> or C<email>, and possibly openIDish results from
506 L<Net::OpenID::Consumer>.
508 Fetches the user object for the given username and returns it.
513 my ($self, $userinfo) = @_;
515 ## A URL field means probably an OpenID based user
516 if( exists $userinfo->{url} ) {
517 _extract_openid_data($userinfo);
520 if (exists $userinfo->{sub} && exists $userinfo->{openid_id}) {
521 return $self->_find_gplus($userinfo);
525 if( exists $userinfo->{username} ) {
526 my $username = $userinfo->{username};
527 ## No logins if user is deactivated (use lookup to fetch to re-activate)
528 $user = $self->lookup(Text::Tradition::User->id_for_user($username));
529 ## If there is an inactive user, skip it
530 return if( $user && !$user->active );
531 } elsif( exists $userinfo->{email} ) {
532 ## Scan the users looking for a matching email
534 $self->scan( sub { push( @matches, @_ )
535 if $_[0]->isa('Text::Tradition::User')
536 && $_[0]->email eq $userinfo->{email} } );
537 $user = shift @matches;
539 # print STDERR "Found user, $username, email is :", $user->email, ":\n";
544 my ($self, $userinfo) = @_;
546 my $sub = $userinfo->{sub};
547 my $openid = $userinfo->{openid_id};
548 my $email = $userinfo->{email};
550 # Do we have a user with the google id already?
552 my $user = $self->find_user({
555 warn "Found by google+id" if $user;
561 # Do we have a user with the openid?
563 $user = $self->find_user({
566 warn "Found by openid" if $user;
567 $user ||= $self->find_user({ email => $userinfo->{email} });
568 warn "Found by email" if $user;
574 my $new_user = $self->add_user({
576 password => $user->password,
578 active => $user->active,
580 openid_id => $openid,
584 foreach my $t (@{ $user->traditions }) {
585 $user->remove_tradition($t);
586 $new_user->add_tradition($t);
588 $self->update($user);
589 $self->update($new_user);
591 # $self->delete_user({ username => $user->id });
595 =head2 modify_user( $userinfo )
597 Takes a hashref of C<username> and C<password> (same as add_user).
599 Retrieves the user, and updates it with the new information. Username
600 changing is not currently supported.
602 Returns the updated user object, or undef if not found.
607 my ($self, $userinfo) = @_;
608 my $username = $userinfo->{username};
609 my $password = $userinfo->{password};
610 my $role = $userinfo->{role};
612 throw( "Missing username" ) unless $username;
614 my $user = $self->find_user({ username => $username });
615 throw( "Could not find user $username" ) unless $user;
618 throw( "Bad password" ) unless $self->validate_password($password);
619 $user->password(crypt_password($password));
625 $self->update($user);
630 =head2 deactivate_user( $userinfo )
632 Takes a hashref of C<username>.
634 Sets the users C<active> flag to false (0), and sets all traditions
635 assigned to them to non-public, updates the storage and returns the
638 Returns undef if user not found.
642 sub deactivate_user {
643 my ($self, $userinfo) = @_;
644 my $username = $userinfo->{username};
646 throw( "Need to specify a username for deactivation" ) unless $username;
648 my $user = $self->find_user({ username => $username });
649 throw( "User $username not found" ) unless $user;
652 foreach my $tradition (@{ $user->traditions }) {
653 ## Not implemented yet
654 # $tradition->public(0);
657 ## Should we be using Text::Tradition::Directory also?
658 $self->update(@{ $user->traditions });
660 $self->update($user);
665 =head2 reactivate_user( $userinfo )
667 Takes a hashref of C<username>.
669 Returns the user object if already activated. Activates (sets the
670 active flag to true (1)), updates the storage and returns the user.
672 Returns undef if the user is not found.
676 sub reactivate_user {
677 my ($self, $userinfo) = @_;
678 my $username = $userinfo->{username};
680 throw( "Need to specify a username for reactivation" ) unless $username;
682 my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
683 throw( "User $username not found" ) unless $user;
685 return $user if $user->active;
688 $self->update($user);
693 =head2 delete_user( $userinfo )
695 CAUTION: Deletes actual data!
697 Takes a hashref of C<username>.
699 Returns undef if the user doesn't exist.
701 Removes the user from the store and returns 1.
706 my ($self, $userinfo) = @_;
707 my $username = $userinfo->{username};
709 throw( "Need to specify a username for deletion" ) unless $username;
711 my $user = $self->find_user({ username => $username });
712 throw( "User $username not found" ) unless $user;
714 ## Should we be using Text::Tradition::Directory for this bit?
715 $self->delete( @{ $user->traditions });
718 $self->delete($user);
723 =head2 validate_password( $password )
725 Takes a password string. Returns true if it is longer than
726 L</MIN_PASS_LEN>, false otherwise.
728 Used internally by L</add_user>.
732 sub validate_password {
733 my ($self, $password) = @_;
735 return if !$password;
736 return if length($password) < $self->MIN_PASS_LEN;
741 =head2 user_traditionlist( $user )
743 Returns a tradition list (see specification above) but containing only
744 those traditions visible to the specified user. If $user is the string
745 'public', returns only publicly-viewable traditions.
749 sub user_traditionlist {
750 my ($self, $user) = @_;
753 if(ref $user && $user->is_admin) {
755 return $self->traditionlist();
757 ## We have a user object already, so just fetch its traditions and use tose
758 foreach my $t (@{ $user->traditions }) {
759 push( @tlist, { 'id' => $self->object_to_id( $t ),
760 'name' => $t->name } );
763 } elsif($user ne 'public') {
764 die "Passed neither a user object nor 'public' to user_traditionlist";
767 ## Search for all traditions which allow public viewing
768 my @list = grep { $_->{public} } $self->traditionlist();
776 This package is free software and is provided "as is" without express
777 or implied warranty. You can redistribute it and/or modify it under
778 the same terms as Perl itself.
782 Tara L Andrews E<lt>aurum@cpan.orgE<gt> (initial release)
784 Shadowcat Systems L<http://www.scsys.co.uk/> (user functionality; making it all work)