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