base/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 Safe::Isa;
  12 use Text::Tradition::Error;
  13
  14 ## users
  15 use KiokuX::User::Util qw(crypt_password);
  16 use Text::Tradition::Store;
  17 use Text::Tradition::User;
  18 use Text::Tradition::TypeMap::Entry;
  19
  20 extends 'KiokuX::Model';
  21
  22 =head1 NAME
  23
  24 Text::Tradition::Directory - a KiokuDB interface for storing and retrieving traditions
  25
  26 =head1 SYNOPSIS
  27
  28   use Text::Tradition::Directory;
  29   my $d = Text::Tradition::Directory->new(
  30     'dsn' => 'dbi:SQLite:mytraditions.db',
  31     'extra_args' => { 'create' => 1 },
  32   );
  33
  34   my $tradition = Text::Tradition->new( @args );
  35   $tradition->enable_stemmata;
  36   my $stemma = $tradition->add_stemma( dotfile => $dotfile );
  37   $d->save_tradition( $tradition );
  38
  39   foreach my $id ( $d->traditions ) {
  40         print $d->tradition( $id )->name;
  41   }
  42
  43   ## Users:
  44   my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
  45   my $newuser = $userstore->add_user({ username => 'fred',
  46                                        password => 'somepassword' });
  47
  48   my $fetchuser = $userstore->find_user({ username => 'fred' });
  49   if($fetchuser->check_password('somepassword')) {
  50      ## login user or .. whatever
  51   }
  52
  53   my $user = $userstore->deactivate_user({ username => 'fred' });
  54   if(!$user->active) {
  55     ## shouldnt be able to login etc
  56   }
  57
  58 =head1 DESCRIPTION
  59
  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.
  61
  62 =head1 ATTRIBUTES
  63
  64 =head2 MIN_PASS_LEN
  65
  66 Constant for the minimum password length when validating passwords,
  67 defaults to "8".
  68
  69 =cut
  70
  71 has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
  72
  73 =head1 METHODS
  74
  75 =head2 new
  76
  77 Returns a Directory object.
  78
  79 =head2 traditionlist
  80
  81 Returns a hashref mapping of ID => name for all traditions in the directory.
  82
  83 =head2 tradition( $id )
  84
  85 Returns the Text::Tradition object of the given ID.
  86
  87 =head2 save( $tradition )
  88
  89 Writes the given tradition to the database, returning its ID.
  90
  91 =head2 delete( $tradition )
  92
  93 Deletes the given tradition object from the database.
  94 WARNING!! Garbage collection does not yet work. Use this sparingly.
  95
  96 =begin testing
  97
  98 use TryCatch;
  99 use File::Temp;
 100 use Safe::Isa;
 101 use Text::Tradition;
 102 use_ok 'Text::Tradition::Directory';
 103
 104 my $fh = File::Temp->new();
 105 my $file = $fh->filename;
 106 $fh->close;
 107 my $dsn = "dbi:SQLite:dbname=$file";
 108 my $uuid;
 109 my $t = Text::Tradition->new(
 110         'name'  => 'inline',
 111         'input' => 'Tabular',
 112         'file'  => 't/data/simple.txt',
 113         );
 114 my $stemma_enabled;
 115 eval { $stemma_enabled = $t->enable_stemmata; };
 116
 117 {
 118         my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
 119                 'extra_args' => { 'create' => 1 } );
 120         ok( $d->$_isa('Text::Tradition::Directory'), "Got directory object" );
 121
 122         my $scope = $d->new_scope;
 123         $uuid = $d->save( $t );
 124         ok( $uuid, "Saved test tradition" );
 125
 126         SKIP: {
 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" );
 132                 try {
 133                         $d->save( $s );
 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" );
 138                 }
 139         }
 140 }
 141 my $nt = Text::Tradition->new(
 142         'name' => 'CX',
 143         'input' => 'CollateX',
 144         'file' => 't/data/Collatex-16.xml',
 145         );
 146 ok( $nt->$_isa('Text::Tradition'), "Made new tradition" );
 147
 148 {
 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" );
 160         my $sid;
 161         SKIP: {
 162                 skip "Analysis package not installed", 4 unless $stemma_enabled;
 163                 $sid = $f->object_to_id( $tf->stemma(0) );
 164                 try {
 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" );
 169                 }
 170                 try {
 171                         $f->delete( $sid );
 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" );
 176                 }
 177         }
 178
 179         $f->delete( $uuid );
 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" );
 183 }
 184
 185 {
 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" );
 193 }
 194
 195 =end testing
 196
 197 =cut
 198 use Text::Tradition::TypeMap::Entry;
 199
 200 has +typemap => (
 201   is      => 'rw',
 202   isa     => 'KiokuDB::TypeMap',
 203   default => sub {
 204     KiokuDB::TypeMap->new(
 205       isa_entries => {
 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
 209         "Text::Tradition" =>
 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(),
 221       }
 222     );
 223   },
 224 );
 225
 226 # Push some columns into the extra_args
 227 around BUILDARGS => sub {
 228         my $orig = shift;
 229         my $class = shift;
 230         my $args;
 231         if( @_ == 1 ) {
 232                 $args = $_[0];
 233         } else {
 234                 $args = { @_ };
 235         }
 236         my @column_args;
 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 } ] );
 241         }
 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 };
 247         } else {
 248                 $ea = { @column_args };
 249         }
 250         $args->{'extra_args'} = $ea;
 251
 252         return $class->$orig( $args );
 253 };
 254
 255 override _build_directory => sub {
 256   my($self) = @_;
 257   Text::Tradition::Store->connect(@{ $self->_connect_args },
 258     resolver_constructor => sub {
 259       my($class) = @_;
 260       $class->new({ typemap => $self->directory->merged_typemap,
 261                     fallback_entry => Text::Tradition::TypeMap::Entry->new() });
 262   });
 263 };
 264
 265 ## These checks don't cover store($id, $obj)
 266 # before [ qw/ store update insert delete / ] => sub {
 267 before [ qw/ delete / ] => sub {
 268         my $self = shift;
 269         my @nontrad;
 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');
 277                         }
 278                         push( @nontrad, $obj );
 279                 }
 280         }
 281         if( @nontrad ) {
 282                 throw( "Cannot directly save non-Tradition object of type "
 283                         . ref( $nontrad[0] ) );
 284         }
 285 };
 286
 287 # TODO Garbage collection doesn't work. Suck it up and live with the
 288 # inflated DB.
 289 after delete => sub {
 290         my $self = shift;
 291         my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
 292         $self->directory->backend->delete( $gc->garbage->members );
 293 };
 294
 295 sub save {
 296         my $self = shift;
 297         return $self->store( @_ );
 298 }
 299
 300 sub tradition {
 301         my( $self, $id ) = @_;
 302         my $obj = $self->lookup( $id );
 303         unless( $obj ) {
 304                 # Try looking up by name.
 305                 foreach my $item ( $self->traditionlist ) {
 306                         if( $item->{'name'} eq $id ) {
 307                                 $obj = $self->lookup( $item->{'id'} );
 308                                 last;
 309                         }
 310                 }
 311         }
 312         if( $obj && !$obj->$_isa('Text::Tradition') ) {
 313                 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
 314         }
 315         return $obj;
 316 }
 317
 318 sub traditionlist {
 319         my $self = shift;
 320     my ($user) = @_;
 321
 322     return $self->user_traditionlist($user) if($user);
 323
 324         my @tlist;
 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+):/ ) {
 328                 my $dbtype = $1;
 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"' );
 336                 $q->execute();
 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] } );
 342                 }
 343         } else {
 344                 $self->scan( sub { my $o = shift;
 345                                                    push( @tlist, { 'id' => $self->object_to_id( $o ),
 346                                                                                    'name' => $o->name,
 347                                                                                    'public' => $o->public } ) } );
 348         }
 349         return @tlist;
 350 }
 351
 352 sub throw {
 353         Text::Tradition::Error->throw(
 354                 'ident' => 'database error',
 355                 'message' => $_[0],
 356                 );
 357 }
 358
 359
 360 # has 'directory' => (
 361 #     is => 'rw',
 362 #     isa => 'KiokuX::Model',
 363 #     handles => []
 364 #     );
 365
 366 ## TODO: Some of these methods should probably optionally take $user objects
 367 ## instead of hashrefs.
 368
 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.
 372
 373 =head1 USER DIRECTORY METHODS
 374
 375 =head2 add_user( $userinfo )
 376
 377 Takes a hashref of C<username>, C<password>.
 378
 379 Create a new user object, store in the KiokuDB backend, and return it.
 380
 381 =cut
 382
 383 sub add_user {
 384     my ($self, $userinfo) = @_;
 385
 386     my $username = $userinfo->{username};
 387     my $password = $userinfo->{password};
 388     my $role = $userinfo->{role} || 'user';
 389
 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?:/ );
 394
 395     my $user = Text::Tradition::User->new(
 396         id => $username,
 397         password => ($password ? crypt_password($password) : ''),
 398         email => ($userinfo->{email} ? $userinfo->{email} : $username),
 399         role => $role,
 400     );
 401
 402     $self->store($user->kiokudb_object_id, $user);
 403
 404     return $user;
 405 }
 406
 407 =head2 create_user( $userinfo )
 408
 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.
 411
 412 =cut
 413
 414 sub create_user {
 415     my ($self, $userinfo) = @_;
 416
 417     ## No username means probably an OpenID based user
 418     if(!exists $userinfo->{username}) {
 419         _extract_openid_data($userinfo);
 420     }
 421
 422     return $self->add_user($userinfo);
 423 }
 424
 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 {
 428     my ($userinfo) = @_;
 429
 430     ## Spec says SHOULD use url as identifier
 431     $userinfo->{username} = $userinfo->{url};
 432
 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
 439
 440         $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
 441     }
 442
 443     return;
 444 }
 445
 446 =head2 find_user( $userinfo )
 447
 448 Takes a hashref of C<username>, and possibly openIDish results from
 449 L<Net::OpenID::Consumer>.
 450
 451 Fetches the user object for the given username and returns it.
 452
 453 =cut
 454
 455 sub find_user {
 456     my ($self, $userinfo) = @_;
 457
 458     ## No username means probably an OpenID based user
 459     if(!exists $userinfo->{username}) {
 460         _extract_openid_data($userinfo);
 461     }
 462
 463     my $username = $userinfo->{username};
 464
 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);
 468
 469 #    print STDERR "Found user, $username, email is :", $user->email, ":\n";
 470
 471     return $user;
 472 }
 473
 474 =head2 modify_user( $userinfo )
 475
 476 Takes a hashref of C<username> and C<password> (same as add_user).
 477
 478 Retrieves the user, and updates it with the new information. Username
 479 changing is not currently supported.
 480
 481 Returns the updated user object, or undef if not found.
 482
 483 =cut
 484
 485 sub modify_user {
 486     my ($self, $userinfo) = @_;
 487     my $username = $userinfo->{username};
 488     my $password = $userinfo->{password};
 489     my $role = $userinfo->{role};
 490
 491     throw( "Missing username" ) unless $username;
 492
 493     my $user = $self->find_user({ username => $username });
 494     throw( "Could not find user $username" ) unless $user;
 495
 496     if($password) {
 497         throw( "Bad password" ) unless $self->validate_password($password);
 498         $user->password(crypt_password($password));
 499     }
 500     if($role) {
 501         $user->role($role);
 502     }
 503
 504     $self->update($user);
 505
 506     return $user;
 507 }
 508
 509 =head2 deactivate_user( $userinfo )
 510
 511 Takes a hashref of C<username>.
 512
 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
 515 deactivated user.
 516
 517 Returns undef if user not found.
 518
 519 =cut
 520
 521 sub deactivate_user {
 522     my ($self, $userinfo) = @_;
 523     my $username = $userinfo->{username};
 524
 525     throw( "Need to specify a username for deactivation" ) unless $username;
 526
 527     my $user = $self->find_user({ username => $username });
 528     throw( "User $username not found" ) unless $user;
 529
 530     $user->active(0);
 531     foreach my $tradition (@{ $user->traditions }) {
 532         ## Not implemented yet
 533         # $tradition->public(0);
 534     }
 535
 536     ## Should we be using Text::Tradition::Directory also?
 537     $self->update(@{ $user->traditions });
 538
 539     $self->update($user);
 540
 541     return $user;
 542 }
 543
 544 =head2 reactivate_user( $userinfo )
 545
 546 Takes a hashref of C<username>.
 547
 548 Returns the user object if already activated. Activates (sets the
 549 active flag to true (1)), updates the storage and returns the user.
 550
 551 Returns undef if the user is not found.
 552
 553 =cut
 554
 555 sub reactivate_user {
 556     my ($self, $userinfo) = @_;
 557     my $username = $userinfo->{username};
 558
 559     throw( "Need to specify a username for reactivation" ) unless $username;
 560
 561     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 562     throw( "User $username not found" ) unless $user;
 563
 564     return $user if $user->active;
 565
 566     $user->active(1);
 567     $self->update($user);
 568
 569     return $user;
 570 }
 571
 572 =head2 delete_user( $userinfo )
 573
 574 CAUTION: Deletes actual data!
 575
 576 Takes a hashref of C<username>.
 577
 578 Returns undef if the user doesn't exist.
 579
 580 Removes the user from the store and returns 1.
 581
 582 =cut
 583
 584 sub delete_user {
 585     my ($self, $userinfo) = @_;
 586     my $username = $userinfo->{username};
 587
 588     throw( "Need to specify a username for deletion" ) unless $username;
 589
 590     my $user = $self->find_user({ username => $username });
 591     throw( "User $username not found" ) unless $user;
 592
 593     ## Should we be using Text::Tradition::Directory for this bit?
 594     $self->delete( @{ $user->traditions });
 595
 596     ## Poof, gone.
 597     $self->delete($user);
 598
 599     return 1;
 600 }
 601
 602 =head2 validate_password( $password )
 603
 604 Takes a password string. Returns true if it is longer than
 605 L</MIN_PASS_LEN>, false otherwise.
 606
 607 Used internally by L</add_user>.
 608
 609 =cut
 610
 611 sub validate_password {
 612     my ($self, $password) = @_;
 613
 614     return if !$password;
 615     return if length($password) < $self->MIN_PASS_LEN;
 616
 617     return 1;
 618 }
 619
 620 =head2 user_traditionlist( $user )
 621
 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.
 625
 626 =cut
 627
 628 sub user_traditionlist {
 629     my ($self, $user) = @_;
 630
 631     my @tlist;
 632     if(ref $user && $user->is_admin) {
 633         ## Admin sees all
 634         return $self->traditionlist();
 635     } elsif(ref $user) {
 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 } );
 640         }
 641         return @tlist;
 642     } elsif($user ne 'public') {
 643         die "Passed neither a user object nor 'public' to user_traditionlist";
 644     }
 645
 646     ## Search for all traditions which allow public viewing
 647         my @list = grep { $_->{public} } $self->traditionlist();
 648         return @list;
 649 }
 650
 651 1;
 652
 653 =head1 LICENSE
 654
 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.
 658
 659 =head1 AUTHOR
 660
 661 Tara L Andrews E<lt>aurum@cpan.orgE<gt>