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 $tradition->enable_stemmata;
36 my $stemma = $tradition->add_stemma( dotfile => $dotfile );
37 $d->save_tradition( $tradition );
39 foreach my $id ( $d->traditions ) {
40 print $d->tradition( $id )->name;
44 my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
45 my $newuser = $userstore->add_user({ username => 'fred',
46 password => 'somepassword' });
48 my $fetchuser = $userstore->find_user({ username => 'fred' });
49 if($fetchuser->check_password('somepassword')) {
50 ## login user or .. whatever
53 my $user = $userstore->deactivate_user({ username => 'fred' });
55 ## shouldnt be able to login etc
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.
66 Constant for the minimum password length when validating passwords,
71 has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
77 Returns a Directory object.
81 Returns a hashref mapping of ID => name for all traditions in the directory.
83 =head2 tradition( $id )
85 Returns the Text::Tradition object of the given ID.
87 =head2 save( $tradition )
89 Writes the given tradition to the database, returning its ID.
91 =head2 delete( $tradition )
93 Deletes the given tradition object from the database.
94 WARNING!! Garbage collection does not yet work. Use this sparingly.
102 use_ok 'Text::Tradition::Directory';
104 my $fh = File::Temp->new();
105 my $file = $fh->filename;
107 my $dsn = "dbi:SQLite:dbname=$file";
109 my $t = Text::Tradition->new(
111 'input' => 'Tabular',
112 'file' => 't/data/simple.txt',
115 eval { $stemma_enabled = $t->enable_stemmata; };
118 my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
119 'extra_args' => { 'create' => 1 } );
120 ok( $d->$_isa('Text::Tradition::Directory'), "Got directory object" );
122 my $scope = $d->new_scope;
123 $uuid = $d->save( $t );
124 ok( $uuid, "Saved test tradition" );
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" );
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" );
141 my $nt = Text::Tradition->new(
143 'input' => 'CollateX',
144 'file' => 't/data/Collatex-16.xml',
146 ok( $nt->$_isa('Text::Tradition'), "Made new tradition" );
149 my $f = Text::Tradition::Directory->new( 'dsn' => $dsn );
150 my $scope = $f->new_scope;
151 is( scalar $f->traditionlist, 1, "Directory index has our tradition" );
152 my $nuuid = $f->save( $nt );
153 ok( $nuuid, "Stored second tradition" );
154 my @tlist = $f->traditionlist;
155 is( scalar @tlist, 2, "Directory index has both traditions" );
156 my $tf = $f->tradition( $uuid );
157 my( $tlobj ) = grep { $_->{'id'} eq $uuid } @tlist;
158 is( $tlobj->{'name'}, $tf->name, "Directory index has correct tradition name" );
159 is( $tf->name, $t->name, "Retrieved the tradition from a new directory" );
162 skip "Analysis package not installed", 4 unless $stemma_enabled;
163 $sid = $f->object_to_id( $tf->stemma(0) );
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" );
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" );
180 ok( !$f->exists( $uuid ), "Object is deleted from DB" );
181 ok( !$f->exists( $sid ), "Object stemma also deleted from DB" ) if $stemma_enabled;
182 is( scalar $f->traditionlist, 1, "Object is deleted from index" );
186 my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
187 my $scope = $g->new_scope;
188 is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
189 my $ntobj = $g->tradition( 'CX' );
190 my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
191 my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
192 is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
198 use Text::Tradition::TypeMap::Entry;
202 isa => 'KiokuDB::TypeMap',
204 KiokuDB::TypeMap->new(
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
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(),
219 "Graph" => Text::Tradition::TypeMap::Entry->new(),
220 "Set::Scalar" => Text::Tradition::TypeMap::Entry->new(),
226 # Push some columns into the extra_args
227 around BUILDARGS => sub {
237 if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
238 @column_args = ( 'columns',
239 [ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 },
240 'public' => { 'data_type' => 'bool', 'is_nullable' => 1 } ] );
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 };
248 $ea = { @column_args };
250 $args->{'extra_args'} = $ea;
252 return $class->$orig( $args );
255 override _build_directory => sub {
257 Text::Tradition::Store->connect(@{ $self->_connect_args },
258 resolver_constructor => sub {
260 $class->new({ typemap => $self->directory->merged_typemap,
261 fallback_entry => Text::Tradition::TypeMap::Entry->new() });
265 ## These checks don't cover store($id, $obj)
266 # before [ qw/ store update insert delete / ] => sub {
267 before [ qw/ delete / ] => sub {
270 foreach my $obj ( @_ ) {
271 if( ref( $obj ) && !$obj->$_isa( 'Text::Tradition' )
272 && !$obj->$_isa('Text::Tradition::User') ) {
273 # Is it an id => Tradition hash?
274 if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
275 my( $k ) = keys %$obj;
276 next if $obj->{$k}->$_isa('Text::Tradition');
278 push( @nontrad, $obj );
282 throw( "Cannot directly save non-Tradition object of type "
283 . ref( $nontrad[0] ) );
287 # TODO Garbage collection doesn't work. Suck it up and live with the
289 after delete => sub {
291 my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
292 $self->directory->backend->delete( $gc->garbage->members );
297 return $self->store( @_ );
301 my( $self, $id ) = @_;
302 my $obj = $self->lookup( $id );
304 # Try looking up by name.
305 foreach my $item ( $self->traditionlist ) {
306 if( $item->{'name'} eq $id ) {
307 $obj = $self->lookup( $item->{'id'} );
312 if( $obj && !$obj->$_isa('Text::Tradition') ) {
313 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
322 return $self->user_traditionlist($user) if($user);
325 # If we are using DBI, we can do it the easy way; if not, the hard way.
326 # Easy way still involves making a separate DBI connection. Ew.
327 if( $self->dsn =~ /^dbi:(\w+):/ ) {
329 my @connection = @{$self->directory->backend->connect_info};
330 # Get rid of KiokuDB-specific arg
331 pop @connection if scalar @connection > 4;
332 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
333 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
334 my $dbh = DBI->connect( @connection );
335 my $q = $dbh->prepare( 'SELECT id, name, public from entries WHERE class = "Text::Tradition"' );
337 while( my @row = $q->fetchrow_array ) {
338 my( $id, $name ) = @row;
339 # Horrible horrible hack
340 $name = decode_utf8( $name ) if $dbtype eq 'mysql';
341 push( @tlist, { 'id' => $row[0], 'name' => $row[1], 'public' => $row[2] } );
344 $self->scan( sub { my $o = shift;
345 push( @tlist, { 'id' => $self->object_to_id( $o ),
347 'public' => $o->public } ) } );
353 Text::Tradition::Error->throw(
354 'ident' => 'database error',
360 # has 'directory' => (
362 # isa => 'KiokuX::Model',
366 ## TODO: Some of these methods should probably optionally take $user objects
367 ## instead of hashrefs.
369 ## It also occurs to me that all these methods don't need to be named
370 ## XX_user, but leaving that way for now incase we merge this code
371 ## into ::Directory for one-store.
373 =head1 USER DIRECTORY METHODS
375 =head2 add_user( $userinfo )
377 Takes a hashref of C<username>, C<password>.
379 Create a new user object, store in the KiokuDB backend, and return it.
384 my ($self, $userinfo) = @_;
386 my $username = $userinfo->{username};
387 my $password = $userinfo->{password};
388 my $role = $userinfo->{role} || 'user';
390 throw( "No username given" ) unless $username;
391 throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
392 . " characters long" )
393 unless ( $self->validate_password($password) || $username =~ /^https?:/ );
395 my $user = Text::Tradition::User->new(
397 password => ($password ? crypt_password($password) : ''),
398 email => ($userinfo->{email} ? $userinfo->{email} : $username),
402 $self->store($user->kiokudb_object_id, $user);
407 =head2 create_user( $userinfo )
409 Takes a hashref that can either be suitable for add_user (see above) or be
410 a hash of OpenID user information from Credential::OpenID.
415 my ($self, $userinfo) = @_;
417 ## No username means probably an OpenID based user
418 if(!exists $userinfo->{username}) {
419 _extract_openid_data($userinfo);
422 return $self->add_user($userinfo);
425 ## Not quite sure where this method should be.. Auth /
426 ## Credential::OpenID just pass us back the chunk of extension data
427 sub _extract_openid_data {
430 ## Spec says SHOULD use url as identifier
431 $userinfo->{username} = $userinfo->{url};
433 ## Use email addy as display if available
434 if(exists $userinfo->{extensions} &&
435 exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
436 defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
437 ## Somewhat ugly attribute extension reponse, contains
438 ## google-email string which we can use as the id
440 $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
446 =head2 find_user( $userinfo )
448 Takes a hashref of C<username>, and possibly openIDish results from
449 L<Net::OpenID::Consumer>.
451 Fetches the user object for the given username and returns it.
456 my ($self, $userinfo) = @_;
458 ## No username means probably an OpenID based user
459 if(!exists $userinfo->{username}) {
460 _extract_openid_data($userinfo);
463 my $username = $userinfo->{username};
465 ## No logins if user is deactivated (use lookup to fetch to re-activate)
466 my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
467 return if(!$user || !$user->active);
469 # print STDERR "Found user, $username, email is :", $user->email, ":\n";
474 =head2 modify_user( $userinfo )
476 Takes a hashref of C<username> and C<password> (same as add_user).
478 Retrieves the user, and updates it with the new information. Username
479 changing is not currently supported.
481 Returns the updated user object, or undef if not found.
486 my ($self, $userinfo) = @_;
487 my $username = $userinfo->{username};
488 my $password = $userinfo->{password};
489 my $role = $userinfo->{role};
491 throw( "Missing username" ) unless $username;
493 my $user = $self->find_user({ username => $username });
494 throw( "Could not find user $username" ) unless $user;
497 throw( "Bad password" ) unless $self->validate_password($password);
498 $user->password(crypt_password($password));
504 $self->update($user);
509 =head2 deactivate_user( $userinfo )
511 Takes a hashref of C<username>.
513 Sets the users C<active> flag to false (0), and sets all traditions
514 assigned to them to non-public, updates the storage and returns the
517 Returns undef if user not found.
521 sub deactivate_user {
522 my ($self, $userinfo) = @_;
523 my $username = $userinfo->{username};
525 throw( "Need to specify a username for deactivation" ) unless $username;
527 my $user = $self->find_user({ username => $username });
528 throw( "User $username not found" ) unless $user;
531 foreach my $tradition (@{ $user->traditions }) {
532 ## Not implemented yet
533 # $tradition->public(0);
536 ## Should we be using Text::Tradition::Directory also?
537 $self->update(@{ $user->traditions });
539 $self->update($user);
544 =head2 reactivate_user( $userinfo )
546 Takes a hashref of C<username>.
548 Returns the user object if already activated. Activates (sets the
549 active flag to true (1)), updates the storage and returns the user.
551 Returns undef if the user is not found.
555 sub reactivate_user {
556 my ($self, $userinfo) = @_;
557 my $username = $userinfo->{username};
559 throw( "Need to specify a username for reactivation" ) unless $username;
561 my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
562 throw( "User $username not found" ) unless $user;
564 return $user if $user->active;
567 $self->update($user);
572 =head2 delete_user( $userinfo )
574 CAUTION: Deletes actual data!
576 Takes a hashref of C<username>.
578 Returns undef if the user doesn't exist.
580 Removes the user from the store and returns 1.
585 my ($self, $userinfo) = @_;
586 my $username = $userinfo->{username};
588 throw( "Need to specify a username for deletion" ) unless $username;
590 my $user = $self->find_user({ username => $username });
591 throw( "User $username not found" ) unless $user;
593 ## Should we be using Text::Tradition::Directory for this bit?
594 $self->delete( @{ $user->traditions });
597 $self->delete($user);
602 =head2 validate_password( $password )
604 Takes a password string. Returns true if it is longer than
605 L</MIN_PASS_LEN>, false otherwise.
607 Used internally by L</add_user>.
611 sub validate_password {
612 my ($self, $password) = @_;
614 return if !$password;
615 return if length($password) < $self->MIN_PASS_LEN;
620 =head2 user_traditionlist( $user )
622 Returns a tradition list (see specification above) but containing only
623 those traditions visible to the specified user. If $user is the string
624 'public', returns only publicly-viewable traditions.
628 sub user_traditionlist {
629 my ($self, $user) = @_;
632 if(ref $user && $user->is_admin) {
634 return $self->traditionlist();
636 ## We have a user object already, so just fetch its traditions and use tose
637 foreach my $t (@{ $user->traditions }) {
638 push( @tlist, { 'id' => $self->object_to_id( $t ),
639 'name' => $t->name } );
642 } elsif($user ne 'public') {
643 die "Passed neither a user object nor 'public' to user_traditionlist";
646 ## Search for all traditions which allow public viewing
647 my @list = grep { $_->{public} } $self->traditionlist();
655 This package is free software and is provided "as is" without express
656 or implied warranty. You can redistribute it and/or modify it under
657 the same terms as Perl itself.
661 Tara L Andrews E<lt>aurum@cpan.orgE<gt>