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