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" );
187 isa => 'KiokuDB::TypeMap',
189 KiokuDB::TypeMap->new(
191 "Graph" => KiokuDB::TypeMap::Entry::Naive->new,
192 "Graph::AdjacencyMap" => KiokuDB::TypeMap::Entry::Naive->new,
198 # Push some columns into the extra_args
199 around BUILDARGS => sub {
208 if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
209 my @column_args = ( 'columns',
210 [ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 } ] );
211 my $ea = $args->{'extra_args'};
212 if( ref( $ea ) eq 'ARRAY' ) {
213 push( @$ea, @column_args );
214 } elsif( ref( $ea ) eq 'HASH' ) {
215 $ea = { %$ea, @column_args };
217 $ea = { @column_args };
219 $args->{'extra_args'} = $ea;
221 return $class->$orig( $args );
224 ## These checks don't cover store($id, $obj)
225 before [ qw/ store update insert delete / ] => sub {
228 foreach my $obj ( @_ ) {
229 if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition'
230 && ref ($obj) ne 'Text::Tradition::User' ) {
231 # Is it an id => Tradition hash?
232 if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
233 my( $k ) = keys %$obj;
234 next if ref( $obj->{$k} ) eq 'Text::Tradition';
236 push( @nontrad, $obj );
240 throw( "Cannot directly save non-Tradition object of type "
241 . ref( $nontrad[0] ) );
245 # TODO Garbage collection doesn't work. Suck it up and live with the
247 # after delete => sub {
249 # my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
250 # $self->directory->backend->delete( $gc->garbage->members );
255 return $self->store( @_ );
259 my( $self, $id ) = @_;
260 my $obj = $self->lookup( $id );
262 # Try looking up by name.
263 foreach my $item ( $self->traditionlist ) {
264 if( $item->{'name'} eq $id ) {
265 $obj = $self->lookup( $item->{'id'} );
270 if( $obj && ref( $obj ) ne 'Text::Tradition' ) {
271 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
276 sub user_traditionlist {
277 my ($self, $user) = @_;
280 if(ref $user && $user->is_admin) {
282 return $self->traditionlist();
284 ## We have a user object already, so just fetch its traditions and use tose
285 foreach my $t (@{ $user->traditions }) {
286 push( @tlist, { 'id' => $self->object_to_id( $t ),
287 'name' => $t->name } );
290 } elsif($user ne 'public') {
291 die "Passed neither a user object nor 'public' to user_traditionlist";
294 ## Search for all traditions which allow public viewing
296 ## This needs to be more sophisticated, probably needs Search::GIN
297 # my $list = $self->search({ public => 1 });
299 ## For now, just fetch all
300 ## (could use all_objects or grep down there?)
301 return $self->traditionlist();
308 return $self->user_traditionlist($user) if($user);
311 # If we are using DBI, we can do it the easy way; if not, the hard way.
312 # Easy way still involves making a separate DBI connection. Ew.
313 if( $self->dsn =~ /^dbi:(\w+):/ ) {
315 my @connection = @{$self->directory->backend->connect_info};
316 # Get rid of KiokuDB-specific arg
317 pop @connection if scalar @connection > 4;
318 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
319 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
320 my $dbh = DBI->connect( @connection );
321 my $q = $dbh->prepare( 'SELECT id, name from entries WHERE class = "Text::Tradition"' );
323 while( my @row = $q->fetchrow_array ) {
324 my( $id, $name ) = @row;
325 # Horrible horrible hack
326 $name = decode_utf8( $name ) if $dbtype eq 'mysql';
327 push( @tlist, { 'id' => $row[0], 'name' => $row[1] } );
330 $self->scan( sub { my $o = shift;
331 push( @tlist, { 'id' => $self->object_to_id( $o ),
332 'name' => $o->name } ) } );
338 Text::Tradition::Error->throw(
339 'ident' => 'database error',
345 # has 'directory' => (
347 # isa => 'KiokuX::Model',
351 ## TODO: Some of these methods should probably optionally take $user objects
352 ## instead of hashrefs.
354 ## It also occurs to me that all these methods don't need to be named
355 ## XX_user, but leaving that way for now incase we merge this code
356 ## into ::Directory for one-store.
358 ## To die or not to die, on error, this is the question.
362 Takes a hashref of C<username>, C<password>.
364 Create a new user object, store in the KiokuDB backend, and return it.
369 my ($self, $userinfo) = @_;
370 my $username = $userinfo->{url} || $userinfo->{username};
371 my $password = $userinfo->{password};
372 my $role = $userinfo->{role} || 'user';
374 return unless ($username =~ /^https?:/
375 || ($username && $self->validate_password($password))) ;
377 my $user = Text::Tradition::User->new(
379 password => ($password ? crypt_password($password) : ''),
383 $self->store($user->kiokudb_object_id, $user);
390 return $self->add_user(@_);
395 Takes a hashref of C<username>, optionally C<openid_identifier>.
397 Fetches the user object for the given username and returns it.
402 my ($self, $userinfo) = @_;
404 # 'display' => 'castaway.myopenid.com',
405 # 'url' => 'http://castaway.myopenid.com/',
406 my $username = $userinfo->{url} || $userinfo->{username};
408 ## No logins if user is deactivated (use lookup to fetch to re-activate)
409 my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
410 return if($user && !$user->active);
418 Takes a hashref of C<username> and C<password> (same as add_user).
420 Retrieves the user, and updates it with the new information. Username
421 changing is not currently supported.
423 Returns the updated user object, or undef if not found.
428 my ($self, $userinfo) = @_;
429 my $username = $userinfo->{username};
430 my $password = $userinfo->{password};
431 my $role = $userinfo->{role};
433 return unless $username;
434 return if($password && !$self->validate_password($password));
436 my $user = $self->find_user({ username => $username });
440 $user->password(crypt_password($password));
446 $self->update($user);
451 =head2 deactivate_user
453 Takes a hashref of C<username>.
455 Sets the users C<active> flag to false (0), and sets all traditions
456 assigned to them to non-public, updates the storage and returns the
459 Returns undef if user not found.
463 sub deactivate_user {
464 my ($self, $userinfo) = @_;
465 my $username = $userinfo->{username};
467 return if !$username;
469 my $user = $self->find_user({ username => $username });
473 foreach my $tradition (@{ $user->traditions }) {
474 ## Not implemented yet
475 # $tradition->public(0);
478 ## Should we be using Text::Tradition::Directory also?
479 $self->update(@{ $user->traditions });
481 $self->update($user);
486 =head2 reactivate_user
488 Takes a hashref of C<username>.
490 Returns the user object if already activated. Activates (sets the
491 active flag to true (1)), updates the storage and returns the user.
493 Returns undef if the user is not found.
497 sub reactivate_user {
498 my ($self, $userinfo) = @_;
499 my $username = $userinfo->{username};
501 return if !$username;
503 my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
506 return $user if $user->active;
509 $self->update($user);
516 CAUTION: Deletes actual data!
518 Takes a hashref of C<username>.
520 Returns undef if the user doesn't exist.
522 Removes the user from the store and returns 1.
527 my ($self, $userinfo) = @_;
528 my $username = $userinfo->{username};
530 return if !$username;
532 my $user = $self->find_user({ username => $username });
535 ## Should we be using Text::Tradition::Directory for this bit?
536 $self->delete( @{ $user->traditions });
539 $self->delete($user);
544 =head2 validate_password
546 Takes a password string. Returns true if it is longer than
547 L</MIN_PASS_LEN>, false otherwise.
549 Used internally by L</add_user>.
553 sub validate_password {
554 my ($self, $password) = @_;
556 return if !$password;
557 return if length($password) < $self->MIN_PASS_LEN;
566 This package is free software and is provided "as is" without express
567 or implied warranty. You can redistribute it and/or modify it under
568 the same terms as Perl itself.
572 Tara L Andrews E<lt>aurum@cpan.orgE<gt>