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