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 user_traditionlist {
 319     my ($self, $user) = @_;
 320
 321     my @tlist;
 322     if(ref $user && $user->is_admin) {
 323         ## Admin sees all
 324         return $self->traditionlist();
 325     } elsif(ref $user) {
 326         ## We have a user object already, so just fetch its traditions and use tose
 327         foreach my $t (@{ $user->traditions }) {
 328             push( @tlist, { 'id' => $self->object_to_id( $t ),
 329                             'name' => $t->name } );
 330         }
 331         return @tlist;
 332     } elsif($user ne 'public') {
 333         die "Passed neither a user object nor 'public' to user_traditionlist";
 334     }
 335
 336     ## Search for all traditions which allow public viewing
 337         my @list = grep { $_->{public} } $self->traditionlist();
 338         return @list;
 339 }
 340
 341 sub traditionlist {
 342         my $self = shift;
 343     my ($user) = @_;
 344
 345     return $self->user_traditionlist($user) if($user);
 346
 347         my @tlist;
 348         # If we are using DBI, we can do it the easy way; if not, the hard way.
 349         # Easy way still involves making a separate DBI connection. Ew.
 350         if( $self->dsn =~ /^dbi:(\w+):/ ) {
 351                 my $dbtype = $1;
 352                 my @connection = @{$self->directory->backend->connect_info};
 353                 # Get rid of KiokuDB-specific arg
 354                 pop @connection if scalar @connection > 4;
 355                 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
 356                 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
 357                 my $dbh = DBI->connect( @connection );
 358                 my $q = $dbh->prepare( 'SELECT id, name, public from entries WHERE class = "Text::Tradition"' );
 359                 $q->execute();
 360                 while( my @row = $q->fetchrow_array ) {
 361                         my( $id, $name ) = @row;
 362                         # Horrible horrible hack
 363                         $name = decode_utf8( $name ) if $dbtype eq 'mysql';
 364                         push( @tlist, { 'id' => $row[0], 'name' => $row[1], 'public' => $row[2] } );
 365                 }
 366         } else {
 367                 $self->scan( sub { my $o = shift;
 368                                                    push( @tlist, { 'id' => $self->object_to_id( $o ),
 369                                                                                    'name' => $o->name,
 370                                                                                    'public' => $o->public } ) } );
 371         }
 372         return @tlist;
 373 }
 374
 375 sub throw {
 376         Text::Tradition::Error->throw(
 377                 'ident' => 'database error',
 378                 'message' => $_[0],
 379                 );
 380 }
 381
 382
 383 # has 'directory' => (
 384 #     is => 'rw',
 385 #     isa => 'KiokuX::Model',
 386 #     handles => []
 387 #     );
 388
 389 ## TODO: Some of these methods should probably optionally take $user objects
 390 ## instead of hashrefs.
 391
 392 ## It also occurs to me that all these methods don't need to be named
 393 ## XX_user, but leaving that way for now incase we merge this code
 394 ## into ::Directory for one-store.
 395
 396 ## To die or not to die, on error, this is the question.
 397
 398 =head2 add_user
 399
 400 Takes a hashref of C<username>, C<password>.
 401
 402 Create a new user object, store in the KiokuDB backend, and return it.
 403
 404 =cut
 405
 406 sub add_user {
 407     my ($self, $userinfo) = @_;
 408
 409     my $username = $userinfo->{username};
 410     my $password = $userinfo->{password};
 411     my $role = $userinfo->{role} || 'user';
 412
 413         throw( "No username given" ) unless $username;
 414         throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
 415                 . " characters long" )
 416                 unless ( $self->validate_password($password) || $username =~ /^https?:/ );
 417
 418     my $user = Text::Tradition::User->new(
 419         id => $username,
 420         password => ($password ? crypt_password($password) : ''),
 421         email => ($userinfo->{email} ? $userinfo->{email} : $username),
 422         role => $role,
 423     );
 424
 425     $self->store($user->kiokudb_object_id, $user);
 426
 427     return $user;
 428 }
 429
 430 sub create_user {
 431     my ($self, $userinfo) = @_;
 432
 433     ## No username means probably an OpenID based user
 434     if(!exists $userinfo->{username}) {
 435         extract_openid_data($userinfo);
 436     }
 437
 438     return $self->add_user($userinfo);
 439 }
 440
 441 ## Not quite sure where this method should be.. Auth /
 442 ## Credential::OpenID just pass us back the chunk of extension data
 443 sub extract_openid_data {
 444     my ($userinfo) = @_;
 445
 446     ## Spec says SHOULD use url as identifier
 447     $userinfo->{username} = $userinfo->{url};
 448
 449     ## Use email addy as display if available
 450     if(exists $userinfo->{extensions} &&
 451          exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
 452          defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
 453         ## Somewhat ugly attribute extension reponse, contains
 454         ## google-email string which we can use as the id
 455
 456         $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
 457     }
 458
 459     return;
 460 }
 461
 462 =head2 find_user
 463
 464 Takes a hashref of C<username>, and possibly openIDish results from
 465 L<Net::OpenID::Consumer>.
 466
 467 Fetches the user object for the given username and returns it.
 468
 469 =cut
 470
 471 sub find_user {
 472     my ($self, $userinfo) = @_;
 473
 474     ## No username means probably an OpenID based user
 475     if(!exists $userinfo->{username}) {
 476         extract_openid_data($userinfo);
 477     }
 478
 479     my $username = $userinfo->{username};
 480
 481     ## No logins if user is deactivated (use lookup to fetch to re-activate)
 482     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 483     return if(!$user || !$user->active);
 484
 485 #    print STDERR "Found user, $username, email is :", $user->email, ":\n";
 486
 487     return $user;
 488 }
 489
 490 =head2 modify_user
 491
 492 Takes a hashref of C<username> and C<password> (same as add_user).
 493
 494 Retrieves the user, and updates it with the new information. Username
 495 changing is not currently supported.
 496
 497 Returns the updated user object, or undef if not found.
 498
 499 =cut
 500
 501 sub modify_user {
 502     my ($self, $userinfo) = @_;
 503     my $username = $userinfo->{username};
 504     my $password = $userinfo->{password};
 505     my $role = $userinfo->{role};
 506
 507     throw( "Missing username" ) unless $username;
 508
 509     my $user = $self->find_user({ username => $username });
 510     throw( "Could not find user $username" ) unless $user;
 511
 512     if($password) {
 513         throw( "Bad password" ) unless $self->validate_password($password);
 514         $user->password(crypt_password($password));
 515     }
 516     if($role) {
 517         $user->role($role);
 518     }
 519
 520     $self->update($user);
 521
 522     return $user;
 523 }
 524
 525 =head2 deactivate_user
 526
 527 Takes a hashref of C<username>.
 528
 529 Sets the users C<active> flag to false (0), and sets all traditions
 530 assigned to them to non-public, updates the storage and returns the
 531 deactivated user.
 532
 533 Returns undef if user not found.
 534
 535 =cut
 536
 537 sub deactivate_user {
 538     my ($self, $userinfo) = @_;
 539     my $username = $userinfo->{username};
 540
 541     throw( "Need to specify a username for deactivation" ) unless $username;
 542
 543     my $user = $self->find_user({ username => $username });
 544     throw( "User $username not found" ) unless $user;
 545
 546     $user->active(0);
 547     foreach my $tradition (@{ $user->traditions }) {
 548         ## Not implemented yet
 549         # $tradition->public(0);
 550     }
 551
 552     ## Should we be using Text::Tradition::Directory also?
 553     $self->update(@{ $user->traditions });
 554
 555     $self->update($user);
 556
 557     return $user;
 558 }
 559
 560 =head2 reactivate_user
 561
 562 Takes a hashref of C<username>.
 563
 564 Returns the user object if already activated. Activates (sets the
 565 active flag to true (1)), updates the storage and returns the user.
 566
 567 Returns undef if the user is not found.
 568
 569 =cut
 570
 571 sub reactivate_user {
 572     my ($self, $userinfo) = @_;
 573     my $username = $userinfo->{username};
 574
 575     throw( "Need to specify a username for reactivation" ) unless $username;
 576
 577     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 578     throw( "User $username not found" ) unless $user;
 579
 580     return $user if $user->active;
 581
 582     $user->active(1);
 583     $self->update($user);
 584
 585     return $user;
 586 }
 587
 588 =head2 delete_user
 589
 590 CAUTION: Deletes actual data!
 591
 592 Takes a hashref of C<username>.
 593
 594 Returns undef if the user doesn't exist.
 595
 596 Removes the user from the store and returns 1.
 597
 598 =cut
 599
 600 sub delete_user {
 601     my ($self, $userinfo) = @_;
 602     my $username = $userinfo->{username};
 603
 604     throw( "Need to specify a username for deletion" ) unless $username;
 605
 606     my $user = $self->find_user({ username => $username });
 607     throw( "User $username not found" ) unless $user;
 608
 609     ## Should we be using Text::Tradition::Directory for this bit?
 610     $self->delete( @{ $user->traditions });
 611
 612     ## Poof, gone.
 613     $self->delete($user);
 614
 615     return 1;
 616 }
 617
 618 =head2 validate_password
 619
 620 Takes a password string. Returns true if it is longer than
 621 L</MIN_PASS_LEN>, false otherwise.
 622
 623 Used internally by L</add_user>.
 624
 625 =cut
 626
 627 sub validate_password {
 628     my ($self, $password) = @_;
 629
 630     return if !$password;
 631     return if length($password) < $self->MIN_PASS_LEN;
 632
 633     return 1;
 634 }
 635
 636 1;
 637
 638 =head1 LICENSE
 639
 640 This package is free software and is provided "as is" without express
 641 or implied warranty.  You can redistribute it and/or modify it under
 642 the same terms as Perl itself.
 643
 644 =head1 AUTHOR
 645
 646 Tara L Andrews E<lt>aurum@cpan.orgE<gt>