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