1 package Text::Tradition::Directory;
7 use Encode qw/ decode_utf8 /;
8 use KiokuDB::GC::Naive;
10 use KiokuDB::TypeMap::Entry::Naive;
11 use Text::Tradition::Error;
14 use KiokuX::User::Util qw(crypt_password);
15 use Text::Tradition::User;
17 extends 'KiokuX::Model';
21 Text::Tradition::Directory - a KiokuDB interface for storing and retrieving traditions
25 use Text::Tradition::Directory;
26 my $d = Text::Tradition::Directory->new(
27 'dsn' => 'dbi:SQLite:mytraditions.db',
28 'extra_args' => { 'create' => 1 },
31 my $tradition = Text::Tradition->new( @args );
32 my $stemma = $tradition->add_stemma( dotfile => $dotfile );
33 $d->save_tradition( $tradition );
35 foreach my $id ( $d->traditions ) {
36 print $d->tradition( $id )->name;
40 my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
41 my $newuser = $userstore->add_user({ username => 'fred',
42 password => 'somepassword' });
44 my $fetchuser = $userstore->find_user({ username => 'fred' });
45 if($fetchuser->check_password('somepassword')) {
46 ## login user or .. whatever
49 my $user = $userstore->deactivate_user({ username => 'fred' });
51 ## shouldnt be able to login etc
56 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.
62 Constant for the minimum password length when validating passwords,
67 has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
73 Returns a Directory object.
77 Returns a hashref mapping of ID => name for all traditions in the directory.
79 =head2 tradition( $id )
81 Returns the Text::Tradition object of the given ID.
83 =head2 save( $tradition )
85 Writes the given tradition to the database, returning its ID.
87 =head2 delete( $tradition )
89 Deletes the given tradition object from the database.
90 WARNING!! Garbage collection does not yet work. Use this sparingly.
97 use_ok 'Text::Tradition::Directory';
99 my $fh = File::Temp->new();
100 my $file = $fh->filename;
102 my $dsn = "dbi:SQLite:dbname=$file";
104 my $t = Text::Tradition->new(
106 'input' => 'Tabular',
107 'file' => 't/data/simple.txt',
111 my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
112 'extra_args' => { 'create' => 1 } );
113 is( ref $d, 'Text::Tradition::Directory', "Got directory object" );
115 my $scope = $d->new_scope;
116 $uuid = $d->save( $t );
117 ok( $uuid, "Saved test tradition" );
119 my $s = $t->add_stemma( dotfile => 't/data/simple.dot' );
120 ok( $d->save( $t ), "Updated tradition with stemma" );
121 is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" );
122 is( $d->tradition( $uuid )->stemma(0), $s, "...and it has the correct stemma" );
125 } catch( Text::Tradition::Error $e ) {
126 is( $e->ident, 'database error', "Got exception trying to save stemma directly" );
127 like( $e->message, qr/Cannot directly save non-Tradition object/,
128 "Exception has correct message" );
131 my $nt = Text::Tradition->new(
133 'input' => 'CollateX',
134 'file' => 't/data/Collatex-16.xml',
136 is( ref( $nt ), 'Text::Tradition', "Made new tradition" );
139 my $f = Text::Tradition::Directory->new( 'dsn' => $dsn );
140 my $scope = $f->new_scope;
141 is( scalar $f->traditionlist, 1, "Directory index has our tradition" );
142 my $nuuid = $f->save( $nt );
143 ok( $nuuid, "Stored second tradition" );
144 my @tlist = $f->traditionlist;
145 is( scalar @tlist, 2, "Directory index has both traditions" );
146 my $tf = $f->tradition( $uuid );
147 my( $tlobj ) = grep { $_->{'id'} eq $uuid } @tlist;
148 is( $tlobj->{'name'}, $tf->name, "Directory index has correct tradition name" );
149 is( $tf->name, $t->name, "Retrieved the tradition from a new directory" );
150 my $sid = $f->object_to_id( $tf->stemma(0) );
152 $f->tradition( $sid );
153 } catch( Text::Tradition::Error $e ) {
154 is( $e->ident, 'database error', "Got exception trying to fetch stemma directly" );
155 like( $e->message, qr/not a Text::Tradition/, "Exception has correct message" );
159 } catch( Text::Tradition::Error $e ) {
160 is( $e->ident, 'database error', "Got exception trying to delete stemma directly" );
161 like( $e->message, qr/Cannot directly delete non-Tradition object/,
162 "Exception has correct message" );
166 ok( !$f->exists( $uuid ), "Object is deleted from DB" );
167 ok( !$f->exists( $sid ), "Object stemma also deleted from DB" );
168 is( scalar $f->traditionlist, 1, "Object is deleted from index" );
172 my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
173 my $scope = $g->new_scope;
174 is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
175 my $ntobj = $g->tradition( 'CX' );
176 my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
177 my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
178 is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
184 use Text::Tradition::TypeMap::Entry;
188 isa => 'KiokuDB::TypeMap',
190 KiokuDB::TypeMap->new(
193 KiokuDB::TypeMap::Entry::Naive->new(),
194 "Graph" => Text::Tradition::TypeMap::Entry->new(),
195 "Graph::AdjacencyMap" => Text::Tradition::TypeMap::Entry->new(),
201 # Push some columns into the extra_args
202 around BUILDARGS => sub {
211 if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
212 my @column_args = ( 'columns',
213 [ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 } ] );
214 my $ea = $args->{'extra_args'};
215 if( ref( $ea ) eq 'ARRAY' ) {
216 push( @$ea, @column_args );
217 } elsif( ref( $ea ) eq 'HASH' ) {
218 $ea = { %$ea, @column_args };
220 $ea = { @column_args };
222 $args->{'extra_args'} = $ea;
224 return $class->$orig( $args );
227 ## These checks don't cover store($id, $obj)
228 # before [ qw/ store update insert delete / ] => sub {
229 before [ qw/ delete / ] => sub {
232 foreach my $obj ( @_ ) {
233 if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition'
234 && ref ($obj) ne 'Text::Tradition::User' ) {
235 # Is it an id => Tradition hash?
236 if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
237 my( $k ) = keys %$obj;
238 next if ref( $obj->{$k} ) eq 'Text::Tradition';
240 push( @nontrad, $obj );
244 throw( "Cannot directly save non-Tradition object of type "
245 . ref( $nontrad[0] ) );
249 # TODO Garbage collection doesn't work. Suck it up and live with the
251 after delete => sub {
253 my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
254 $self->directory->backend->delete( $gc->garbage->members );
259 return $self->store( @_ );
263 my( $self, $id ) = @_;
264 my $obj = $self->lookup( $id );
266 # Try looking up by name.
267 foreach my $item ( $self->traditionlist ) {
268 if( $item->{'name'} eq $id ) {
269 $obj = $self->lookup( $item->{'id'} );
274 if( $obj && ref( $obj ) ne 'Text::Tradition' ) {
275 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
280 sub user_traditionlist {
281 my ($self, $user) = @_;
284 if(ref $user && $user->is_admin) {
286 return $self->traditionlist();
288 ## We have a user object already, so just fetch its traditions and use tose
289 foreach my $t (@{ $user->traditions }) {
290 push( @tlist, { 'id' => $self->object_to_id( $t ),
291 'name' => $t->name } );
294 } elsif($user ne 'public') {
295 die "Passed neither a user object nor 'public' to user_traditionlist";
298 ## Search for all traditions which allow public viewing
300 ## This needs to be more sophisticated, probably needs Search::GIN
301 # my $list = $self->search({ public => 1 });
303 ## For now, just fetch all
304 ## (could use all_objects or grep down there?)
305 return $self->traditionlist();
312 return $self->user_traditionlist($user) if($user);
315 # If we are using DBI, we can do it the easy way; if not, the hard way.
316 # Easy way still involves making a separate DBI connection. Ew.
317 if( $self->dsn =~ /^dbi:(\w+):/ ) {
319 my @connection = @{$self->directory->backend->connect_info};
320 # Get rid of KiokuDB-specific arg
321 pop @connection if scalar @connection > 4;
322 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
323 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
324 my $dbh = DBI->connect( @connection );
325 my $q = $dbh->prepare( 'SELECT id, name from entries WHERE class = "Text::Tradition"' );
327 while( my @row = $q->fetchrow_array ) {
328 my( $id, $name ) = @row;
329 # Horrible horrible hack
330 $name = decode_utf8( $name ) if $dbtype eq 'mysql';
331 push( @tlist, { 'id' => $row[0], 'name' => $row[1] } );
334 $self->scan( sub { my $o = shift;
335 push( @tlist, { 'id' => $self->object_to_id( $o ),
336 'name' => $o->name } ) } );
342 Text::Tradition::Error->throw(
343 'ident' => 'database error',
349 # has 'directory' => (
351 # isa => 'KiokuX::Model',
355 ## TODO: Some of these methods should probably optionally take $user objects
356 ## instead of hashrefs.
358 ## It also occurs to me that all these methods don't need to be named
359 ## XX_user, but leaving that way for now incase we merge this code
360 ## into ::Directory for one-store.
362 ## To die or not to die, on error, this is the question.
366 Takes a hashref of C<username>, C<password>.
368 Create a new user object, store in the KiokuDB backend, and return it.
373 my ($self, $userinfo) = @_;
375 my $username = $userinfo->{username};
376 my $password = $userinfo->{password};
377 my $role = $userinfo->{role} || 'user';
379 throw( "No username given" ) unless $username;
380 throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
381 . " characters long" )
382 unless ( $self->validate_password($password) || $username =~ /^https?:/ );
384 my $user = Text::Tradition::User->new(
386 password => ($password ? crypt_password($password) : ''),
387 email => ($userinfo->{email} ? $userinfo->{email} : $username),
391 $self->store($user->kiokudb_object_id, $user);
397 my ($self, $userinfo) = @_;
399 ## No username means probably an OpenID based user
400 if(!exists $userinfo->{username}) {
401 extract_openid_data($userinfo);
404 return $self->add_user($userinfo);
407 ## Not quite sure where this method should be.. Auth /
408 ## Credential::OpenID just pass us back the chunk of extension data
409 sub extract_openid_data {
412 ## Spec says SHOULD use url as identifier
413 $userinfo->{username} = $userinfo->{url};
415 ## Use email addy as display if available
416 if(exists $userinfo->{extensions} &&
417 exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
418 defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
419 ## Somewhat ugly attribute extension reponse, contains
420 ## google-email string which we can use as the id
422 $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
430 Takes a hashref of C<username>, and possibly openIDish results from
431 L<Net::OpenID::Consumer>.
433 Fetches the user object for the given username and returns it.
438 my ($self, $userinfo) = @_;
440 ## No username means probably an OpenID based user
441 if(!exists $userinfo->{username}) {
442 extract_openid_data($userinfo);
445 my $username = $userinfo->{username};
447 ## No logins if user is deactivated (use lookup to fetch to re-activate)
448 my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
449 return if(!$user || !$user->active);
451 print STDERR "Found user, $username, email is :", $user->email, ":\n";
458 Takes a hashref of C<username> and C<password> (same as add_user).
460 Retrieves the user, and updates it with the new information. Username
461 changing is not currently supported.
463 Returns the updated user object, or undef if not found.
468 my ($self, $userinfo) = @_;
469 my $username = $userinfo->{username};
470 my $password = $userinfo->{password};
471 my $role = $userinfo->{role};
473 throw( "Missing username or bad password" )
474 unless $username && $self->validate_password($password);
476 my $user = $self->find_user({ username => $username });
477 throw( "Could not find user $username" ) unless $user;
480 $user->password(crypt_password($password));
486 $self->update($user);
491 =head2 deactivate_user
493 Takes a hashref of C<username>.
495 Sets the users C<active> flag to false (0), and sets all traditions
496 assigned to them to non-public, updates the storage and returns the
499 Returns undef if user not found.
503 sub deactivate_user {
504 my ($self, $userinfo) = @_;
505 my $username = $userinfo->{username};
507 throw( "Need to specify a username for deactivation" ) unless $username;
509 my $user = $self->find_user({ username => $username });
510 throw( "User $username not found" ) unless $user;
513 foreach my $tradition (@{ $user->traditions }) {
514 ## Not implemented yet
515 # $tradition->public(0);
518 ## Should we be using Text::Tradition::Directory also?
519 $self->update(@{ $user->traditions });
521 $self->update($user);
526 =head2 reactivate_user
528 Takes a hashref of C<username>.
530 Returns the user object if already activated. Activates (sets the
531 active flag to true (1)), updates the storage and returns the user.
533 Returns undef if the user is not found.
537 sub reactivate_user {
538 my ($self, $userinfo) = @_;
539 my $username = $userinfo->{username};
541 throw( "Need to specify a username for reactivation" ) unless $username;
543 my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
544 throw( "User $username not found" ) unless $user;
546 return $user if $user->active;
549 $self->update($user);
556 CAUTION: Deletes actual data!
558 Takes a hashref of C<username>.
560 Returns undef if the user doesn't exist.
562 Removes the user from the store and returns 1.
567 my ($self, $userinfo) = @_;
568 my $username = $userinfo->{username};
570 throw( "Need to specify a username for deletion" ) unless $username;
572 my $user = $self->find_user({ username => $username });
573 throw( "User $username not found" ) unless $user;
575 ## Should we be using Text::Tradition::Directory for this bit?
576 $self->delete( @{ $user->traditions });
579 $self->delete($user);
584 =head2 validate_password
586 Takes a password string. Returns true if it is longer than
587 L</MIN_PASS_LEN>, false otherwise.
589 Used internally by L</add_user>.
593 sub validate_password {
594 my ($self, $password) = @_;
596 return if !$password;
597 return if length($password) < $self->MIN_PASS_LEN;
606 This package is free software and is provided "as is" without express
607 or implied warranty. You can redistribute it and/or modify it under
608 the same terms as Perl itself.
612 Tara L Andrews E<lt>aurum@cpan.orgE<gt>