lib/Text/Tradition/Directory.pm

   1 package Text::Tradition::Directory;
   2
   3 use strict;
   4 use warnings;
   5 use Moose;
   6 use DBI;
   7 use Encode qw/ decode_utf8 /;
   8 use KiokuDB::GC::Naive;
   9 use KiokuDB::TypeMap;
  10 use KiokuDB::TypeMap::Entry::Naive;
  11 use Text::Tradition::Error;
  12
  13 ## users
  14 use KiokuX::User::Util qw(crypt_password);
  15 use Text::Tradition::Store;
  16 use Text::Tradition::User;
  17 use Text::Tradition::TypeMap::Entry;
  18
  19 extends 'KiokuX::Model';
  20
  21 =head1 NAME
  22
  23 Text::Tradition::Directory - a KiokuDB interface for storing and retrieving traditions
  24
  25 =head1 SYNOPSIS
  26
  27   use Text::Tradition::Directory;
  28   my $d = Text::Tradition::Directory->new(
  29     'dsn' => 'dbi:SQLite:mytraditions.db',
  30     'extra_args' => { 'create' => 1 },
  31   );
  32
  33   my $tradition = Text::Tradition->new( @args );
  34   my $stemma = $tradition->add_stemma( dotfile => $dotfile );
  35   $d->save_tradition( $tradition );
  36
  37   foreach my $id ( $d->traditions ) {
  38         print $d->tradition( $id )->name;
  39   }
  40
  41   ## Users:
  42   my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
  43   my $newuser = $userstore->add_user({ username => 'fred',
  44                                        password => 'somepassword' });
  45
  46   my $fetchuser = $userstore->find_user({ username => 'fred' });
  47   if($fetchuser->check_password('somepassword')) {
  48      ## login user or .. whatever
  49   }
  50
  51   my $user = $userstore->deactivate_user({ username => 'fred' });
  52   if(!$user->active) {
  53     ## shouldnt be able to login etc
  54   }
  55
  56 =head1 DESCRIPTION
  57
  58 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.
  59
  60 =head1 ATTRIBUTES
  61
  62 =head2 MIN_PASS_LEN
  63
  64 Constant for the minimum password length when validating passwords,
  65 defaults to "8".
  66
  67 =cut
  68
  69 has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
  70
  71 =head1 METHODS
  72
  73 =head2 new
  74
  75 Returns a Directory object.
  76
  77 =head2 traditionlist
  78
  79 Returns a hashref mapping of ID => name for all traditions in the directory.
  80
  81 =head2 tradition( $id )
  82
  83 Returns the Text::Tradition object of the given ID.
  84
  85 =head2 save( $tradition )
  86
  87 Writes the given tradition to the database, returning its ID.
  88
  89 =head2 delete( $tradition )
  90
  91 Deletes the given tradition object from the database.
  92 WARNING!! Garbage collection does not yet work. Use this sparingly.
  93
  94 =begin testing
  95
  96 use TryCatch;
  97 use File::Temp;
  98 use Text::Tradition;
  99 use_ok 'Text::Tradition::Directory';
 100
 101 my $fh = File::Temp->new();
 102 my $file = $fh->filename;
 103 $fh->close;
 104 my $dsn = "dbi:SQLite:dbname=$file";
 105 my $uuid;
 106 my $t = Text::Tradition->new(
 107         'name'  => 'inline',
 108         'input' => 'Tabular',
 109         'file'  => 't/data/simple.txt',
 110         );
 111
 112 {
 113         my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
 114                 'extra_args' => { 'create' => 1 } );
 115         is( ref $d, 'Text::Tradition::Directory', "Got directory object" );
 116
 117         my $scope = $d->new_scope;
 118         $uuid = $d->save( $t );
 119         ok( $uuid, "Saved test tradition" );
 120
 121         my $s = $t->add_stemma( dotfile => 't/data/simple.dot' );
 122         ok( $d->save( $t ), "Updated tradition with stemma" );
 123         is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" );
 124         is( $d->tradition( $uuid )->stemma(0), $s, "...and it has the correct stemma" );
 125         try {
 126                 $d->save( $s );
 127         } catch( Text::Tradition::Error $e ) {
 128                 is( $e->ident, 'database error', "Got exception trying to save stemma directly" );
 129                 like( $e->message, qr/Cannot directly save non-Tradition object/,
 130                         "Exception has correct message" );
 131         }
 132 }
 133 my $nt = Text::Tradition->new(
 134         'name' => 'CX',
 135         'input' => 'CollateX',
 136         'file' => 't/data/Collatex-16.xml',
 137         );
 138 is( ref( $nt ), 'Text::Tradition', "Made new tradition" );
 139
 140 {
 141         my $f = Text::Tradition::Directory->new( 'dsn' => $dsn );
 142         my $scope = $f->new_scope;
 143         is( scalar $f->traditionlist, 1, "Directory index has our tradition" );
 144         my $nuuid = $f->save( $nt );
 145         ok( $nuuid, "Stored second tradition" );
 146         my @tlist = $f->traditionlist;
 147         is( scalar @tlist, 2, "Directory index has both traditions" );
 148         my $tf = $f->tradition( $uuid );
 149         my( $tlobj ) = grep { $_->{'id'} eq $uuid } @tlist;
 150         is( $tlobj->{'name'}, $tf->name, "Directory index has correct tradition name" );
 151         is( $tf->name, $t->name, "Retrieved the tradition from a new directory" );
 152         my $sid = $f->object_to_id( $tf->stemma(0) );
 153         try {
 154                 $f->tradition( $sid );
 155         } catch( Text::Tradition::Error $e ) {
 156                 is( $e->ident, 'database error', "Got exception trying to fetch stemma directly" );
 157                 like( $e->message, qr/not a Text::Tradition/, "Exception has correct message" );
 158         }
 159         try {
 160                 $f->delete( $sid );
 161         } catch( Text::Tradition::Error $e ) {
 162                 is( $e->ident, 'database error', "Got exception trying to delete stemma directly" );
 163                 like( $e->message, qr/Cannot directly delete non-Tradition object/,
 164                         "Exception has correct message" );
 165         }
 166
 167         $f->delete( $uuid );
 168         ok( !$f->exists( $uuid ), "Object is deleted from DB" );
 169         ok( !$f->exists( $sid ), "Object stemma also deleted from DB" );
 170         is( scalar $f->traditionlist, 1, "Object is deleted from index" );
 171 }
 172
 173 {
 174         my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
 175         my $scope = $g->new_scope;
 176         is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
 177         my $ntobj = $g->tradition( 'CX' );
 178         my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
 179         my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
 180         is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
 181 }
 182
 183 =end testing
 184
 185 =cut
 186 use Text::Tradition::TypeMap::Entry;
 187
 188 has +typemap => (
 189   is      => 'rw',
 190   isa     => 'KiokuDB::TypeMap',
 191   default => sub {
 192     KiokuDB::TypeMap->new(
 193       isa_entries => {
 194         # now that we fall back to YAML deflation, all attributes of
 195         # Text::Tradition will be serialized to YAML as individual objects
 196         # Except if we declare a specific entry type here
 197         "Text::Tradition" =>
 198           KiokuDB::TypeMap::Entry::MOP->new(),
 199         # We need users to be naive entries so that they hold
 200         # references to the original tradition objects, not clones
 201         "Text::Tradition::User" =>
 202           KiokuDB::TypeMap::Entry::MOP->new(),
 203         "Text::Tradition::Collation" =>
 204           KiokuDB::TypeMap::Entry::MOP->new(),
 205         "Text::Tradition::Witness" =>
 206           KiokuDB::TypeMap::Entry::MOP->new(),
 207         "Graph" => Text::Tradition::TypeMap::Entry->new(),
 208         "Set::Scalar" => Text::Tradition::TypeMap::Entry->new(),
 209       }
 210     );
 211   },
 212 );
 213
 214 # Push some columns into the extra_args
 215 around BUILDARGS => sub {
 216         my $orig = shift;
 217         my $class = shift;
 218         my $args;
 219         if( @_ == 1 ) {
 220                 $args = $_[0];
 221         } else {
 222                 $args = { @_ };
 223         }
 224         my @column_args;
 225         if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
 226                 @column_args = ( 'columns',
 227                         [ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 } ] );
 228         }
 229         my $ea = $args->{'extra_args'};
 230         if( ref( $ea ) eq 'ARRAY' ) {
 231                 push( @$ea, @column_args );
 232         } elsif( ref( $ea ) eq 'HASH' ) {
 233                 $ea = { %$ea, @column_args };
 234         } else {
 235                 $ea = { @column_args };
 236         }
 237         $args->{'extra_args'} = $ea;
 238
 239         return $class->$orig( $args );
 240 };
 241
 242 override _build_directory => sub {
 243   my($self) = @_;
 244   Text::Tradition::Store->connect(@{ $self->_connect_args },
 245     resolver_constructor => sub {
 246       my($class) = @_;
 247       $class->new({ typemap => $self->directory->merged_typemap,
 248                     fallback_entry => Text::Tradition::TypeMap::Entry->new() });
 249   });
 250 };
 251
 252 ## These checks don't cover store($id, $obj)
 253 # before [ qw/ store update insert delete / ] => sub {
 254 before [ qw/ delete / ] => sub {
 255         my $self = shift;
 256         my @nontrad;
 257         foreach my $obj ( @_ ) {
 258                 if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition'
 259             && ref ($obj) ne 'Text::Tradition::User' ) {
 260                         # Is it an id => Tradition hash?
 261                         if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
 262                                 my( $k ) = keys %$obj;
 263                                 next if ref( $obj->{$k} ) eq 'Text::Tradition';
 264                         }
 265                         push( @nontrad, $obj );
 266                 }
 267         }
 268         if( @nontrad ) {
 269                 throw( "Cannot directly save non-Tradition object of type "
 270                         . ref( $nontrad[0] ) );
 271         }
 272 };
 273
 274 # TODO Garbage collection doesn't work. Suck it up and live with the
 275 # inflated DB.
 276 after delete => sub {
 277         my $self = shift;
 278         my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
 279         $self->directory->backend->delete( $gc->garbage->members );
 280 };
 281
 282 sub save {
 283         my $self = shift;
 284         return $self->store( @_ );
 285 }
 286
 287 sub tradition {
 288         my( $self, $id ) = @_;
 289         my $obj = $self->lookup( $id );
 290         unless( $obj ) {
 291                 # Try looking up by name.
 292                 foreach my $item ( $self->traditionlist ) {
 293                         if( $item->{'name'} eq $id ) {
 294                                 $obj = $self->lookup( $item->{'id'} );
 295                                 last;
 296                         }
 297                 }
 298         }
 299         if( $obj && ref( $obj ) ne 'Text::Tradition' ) {
 300                 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
 301         }
 302         return $obj;
 303 }
 304
 305 sub user_traditionlist {
 306     my ($self, $user) = @_;
 307
 308     my @tlist;
 309     if(ref $user && $user->is_admin) {
 310         ## Admin sees all
 311         return $self->traditionlist();
 312     } elsif(ref $user) {
 313         ## We have a user object already, so just fetch its traditions and use tose
 314         foreach my $t (@{ $user->traditions }) {
 315             push( @tlist, { 'id' => $self->object_to_id( $t ),
 316                             'name' => $t->name } );
 317         }
 318         return @tlist;
 319     } elsif($user ne 'public') {
 320         die "Passed neither a user object nor 'public' to user_traditionlist";
 321     }
 322
 323     ## Search for all traditions which allow public viewing
 324     ## When they exist!
 325 ## This needs to be more sophisticated, probably needs Search::GIN
 326 #    my $list = $self->search({ public => 1 });
 327
 328     ## For now, just fetch all
 329     ## (could use all_objects or grep down there?)
 330     return $self->traditionlist();
 331 }
 332
 333 sub traditionlist {
 334         my $self = shift;
 335     my ($user) = @_;
 336
 337     return $self->user_traditionlist($user) if($user);
 338
 339         my @tlist;
 340         # If we are using DBI, we can do it the easy way; if not, the hard way.
 341         # Easy way still involves making a separate DBI connection. Ew.
 342         if( $self->dsn =~ /^dbi:(\w+):/ ) {
 343                 my $dbtype = $1;
 344                 my @connection = @{$self->directory->backend->connect_info};
 345                 # Get rid of KiokuDB-specific arg
 346                 pop @connection if scalar @connection > 4;
 347                 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
 348                 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
 349                 my $dbh = DBI->connect( @connection );
 350                 my $q = $dbh->prepare( 'SELECT id, name from entries WHERE class = "Text::Tradition"' );
 351                 $q->execute();
 352                 while( my @row = $q->fetchrow_array ) {
 353                         my( $id, $name ) = @row;
 354                         # Horrible horrible hack
 355                         $name = decode_utf8( $name ) if $dbtype eq 'mysql';
 356                         push( @tlist, { 'id' => $row[0], 'name' => $row[1] } );
 357                 }
 358         } else {
 359                 $self->scan( sub { my $o = shift;
 360                                                    push( @tlist, { 'id' => $self->object_to_id( $o ),
 361                                                                                    'name' => $o->name } ) } );
 362         }
 363         return @tlist;
 364 }
 365
 366 sub throw {
 367         Text::Tradition::Error->throw(
 368                 'ident' => 'database error',
 369                 'message' => $_[0],
 370                 );
 371 }
 372
 373
 374 # has 'directory' => (
 375 #     is => 'rw',
 376 #     isa => 'KiokuX::Model',
 377 #     handles => []
 378 #     );
 379
 380 ## TODO: Some of these methods should probably optionally take $user objects
 381 ## instead of hashrefs.
 382
 383 ## It also occurs to me that all these methods don't need to be named
 384 ## XX_user, but leaving that way for now incase we merge this code
 385 ## into ::Directory for one-store.
 386
 387 ## To die or not to die, on error, this is the question.
 388
 389 =head2 add_user
 390
 391 Takes a hashref of C<username>, C<password>.
 392
 393 Create a new user object, store in the KiokuDB backend, and return it.
 394
 395 =cut
 396
 397 sub add_user {
 398     my ($self, $userinfo) = @_;
 399
 400     my $username = $userinfo->{username};
 401     my $password = $userinfo->{password};
 402     my $role = $userinfo->{role} || 'user';
 403
 404         throw( "No username given" ) unless $username;
 405         throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
 406                 . " characters long" )
 407                 unless ( $self->validate_password($password) || $username =~ /^https?:/ );
 408
 409     my $user = Text::Tradition::User->new(
 410         id => $username,
 411         password => ($password ? crypt_password($password) : ''),
 412         email => ($userinfo->{email} ? $userinfo->{email} : $username),
 413         role => $role,
 414     );
 415
 416     $self->store($user->kiokudb_object_id, $user);
 417
 418     return $user;
 419 }
 420
 421 sub create_user {
 422     my ($self, $userinfo) = @_;
 423
 424     ## No username means probably an OpenID based user
 425     if(!exists $userinfo->{username}) {
 426         extract_openid_data($userinfo);
 427     }
 428
 429     return $self->add_user($userinfo);
 430 }
 431
 432 ## Not quite sure where this method should be.. Auth /
 433 ## Credential::OpenID just pass us back the chunk of extension data
 434 sub extract_openid_data {
 435     my ($userinfo) = @_;
 436
 437     ## Spec says SHOULD use url as identifier
 438     $userinfo->{username} = $userinfo->{url};
 439
 440     ## Use email addy as display if available
 441     if(exists $userinfo->{extensions} &&
 442          exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
 443          defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
 444         ## Somewhat ugly attribute extension reponse, contains
 445         ## google-email string which we can use as the id
 446
 447         $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
 448     }
 449
 450     return;
 451 }
 452
 453 =head2 find_user
 454
 455 Takes a hashref of C<username>, and possibly openIDish results from
 456 L<Net::OpenID::Consumer>.
 457
 458 Fetches the user object for the given username and returns it.
 459
 460 =cut
 461
 462 sub find_user {
 463     my ($self, $userinfo) = @_;
 464
 465     ## No username means probably an OpenID based user
 466     if(!exists $userinfo->{username}) {
 467         extract_openid_data($userinfo);
 468     }
 469
 470     my $username = $userinfo->{username};
 471
 472     ## No logins if user is deactivated (use lookup to fetch to re-activate)
 473     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 474     return if(!$user || !$user->active);
 475
 476 #    print STDERR "Found user, $username, email is :", $user->email, ":\n";
 477
 478     return $user;
 479 }
 480
 481 =head2 modify_user
 482
 483 Takes a hashref of C<username> and C<password> (same as add_user).
 484
 485 Retrieves the user, and updates it with the new information. Username
 486 changing is not currently supported.
 487
 488 Returns the updated user object, or undef if not found.
 489
 490 =cut
 491
 492 sub modify_user {
 493     my ($self, $userinfo) = @_;
 494     my $username = $userinfo->{username};
 495     my $password = $userinfo->{password};
 496     my $role = $userinfo->{role};
 497
 498     throw( "Missing username or bad password" )
 499         unless $username && $self->validate_password($password);
 500
 501     my $user = $self->find_user({ username => $username });
 502     throw( "Could not find user $username" ) unless $user;
 503
 504     if($password) {
 505         $user->password(crypt_password($password));
 506     }
 507     if($role) {
 508         $user->role($role);
 509     }
 510
 511     $self->update($user);
 512
 513     return $user;
 514 }
 515
 516 =head2 deactivate_user
 517
 518 Takes a hashref of C<username>.
 519
 520 Sets the users C<active> flag to false (0), and sets all traditions
 521 assigned to them to non-public, updates the storage and returns the
 522 deactivated user.
 523
 524 Returns undef if user not found.
 525
 526 =cut
 527
 528 sub deactivate_user {
 529     my ($self, $userinfo) = @_;
 530     my $username = $userinfo->{username};
 531
 532     throw( "Need to specify a username for deactivation" ) unless $username;
 533
 534     my $user = $self->find_user({ username => $username });
 535     throw( "User $username not found" ) unless $user;
 536
 537     $user->active(0);
 538     foreach my $tradition (@{ $user->traditions }) {
 539         ## Not implemented yet
 540         # $tradition->public(0);
 541     }
 542
 543     ## Should we be using Text::Tradition::Directory also?
 544     $self->update(@{ $user->traditions });
 545
 546     $self->update($user);
 547
 548     return $user;
 549 }
 550
 551 =head2 reactivate_user
 552
 553 Takes a hashref of C<username>.
 554
 555 Returns the user object if already activated. Activates (sets the
 556 active flag to true (1)), updates the storage and returns the user.
 557
 558 Returns undef if the user is not found.
 559
 560 =cut
 561
 562 sub reactivate_user {
 563     my ($self, $userinfo) = @_;
 564     my $username = $userinfo->{username};
 565
 566     throw( "Need to specify a username for reactivation" ) unless $username;
 567
 568     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 569     throw( "User $username not found" ) unless $user;
 570
 571     return $user if $user->active;
 572
 573     $user->active(1);
 574     $self->update($user);
 575
 576     return $user;
 577 }
 578
 579 =head2 delete_user
 580
 581 CAUTION: Deletes actual data!
 582
 583 Takes a hashref of C<username>.
 584
 585 Returns undef if the user doesn't exist.
 586
 587 Removes the user from the store and returns 1.
 588
 589 =cut
 590
 591 sub delete_user {
 592     my ($self, $userinfo) = @_;
 593     my $username = $userinfo->{username};
 594
 595     throw( "Need to specify a username for deletion" ) unless $username;
 596
 597     my $user = $self->find_user({ username => $username });
 598     throw( "User $username not found" ) unless $user;
 599
 600     ## Should we be using Text::Tradition::Directory for this bit?
 601     $self->delete( @{ $user->traditions });
 602
 603     ## Poof, gone.
 604     $self->delete($user);
 605
 606     return 1;
 607 }
 608
 609 =head2 validate_password
 610
 611 Takes a password string. Returns true if it is longer than
 612 L</MIN_PASS_LEN>, false otherwise.
 613
 614 Used internally by L</add_user>.
 615
 616 =cut
 617
 618 sub validate_password {
 619     my ($self, $password) = @_;
 620
 621     return if !$password;
 622     return if length($password) < $self->MIN_PASS_LEN;
 623
 624     return 1;
 625 }
 626
 627 1;
 628
 629 =head1 LICENSE
 630
 631 This package is free software and is provided "as is" without express
 632 or implied warranty.  You can redistribute it and/or modify it under
 633 the same terms as Perl itself.
 634
 635 =head1 AUTHOR
 636
 637 Tara L Andrews E<lt>aurum@cpan.orgE<gt>