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> or C<email>, 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     ## A URL field means probably an OpenID based user
 470     if( exists $userinfo->{url} ) {
 471         _extract_openid_data($userinfo);
 472     }
 473
 474         my $user;
 475         if( exists $userinfo->{username} ) {
 476         my $username = $userinfo->{username};
 477                 ## No logins if user is deactivated (use lookup to fetch to re-activate)
 478                 $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 479                 ## If there is an inactive user, skip it
 480                 return if( $user && !$user->active );
 481         } elsif( exists $userinfo->{email} ) {
 482                 ## Scan the users looking for a matching email
 483                 my @matches;
 484                 $self->scan( sub { push( @matches, @_ )
 485                         if $_[0]->isa('Text::Tradition::User')
 486                         && $_[0]->email eq $userinfo->{email} } );
 487                 $user = shift @matches;
 488         }
 489 #    print STDERR "Found user, $username, email is :", $user->email, ":\n";
 490     return $user;
 491 }
 492
 493 =head2 modify_user( $userinfo )
 494
 495 Takes a hashref of C<username> and C<password> (same as add_user).
 496
 497 Retrieves the user, and updates it with the new information. Username
 498 changing is not currently supported.
 499
 500 Returns the updated user object, or undef if not found.
 501
 502 =cut
 503
 504 sub modify_user {
 505     my ($self, $userinfo) = @_;
 506     my $username = $userinfo->{username};
 507     my $password = $userinfo->{password};
 508     my $role = $userinfo->{role};
 509
 510     throw( "Missing username" ) unless $username;
 511
 512     my $user = $self->find_user({ username => $username });
 513     throw( "Could not find user $username" ) unless $user;
 514
 515     if($password) {
 516         throw( "Bad password" ) unless $self->validate_password($password);
 517         $user->password(crypt_password($password));
 518     }
 519     if($role) {
 520         $user->role($role);
 521     }
 522
 523     $self->update($user);
 524
 525     return $user;
 526 }
 527
 528 =head2 deactivate_user( $userinfo )
 529
 530 Takes a hashref of C<username>.
 531
 532 Sets the users C<active> flag to false (0), and sets all traditions
 533 assigned to them to non-public, updates the storage and returns the
 534 deactivated user.
 535
 536 Returns undef if user not found.
 537
 538 =cut
 539
 540 sub deactivate_user {
 541     my ($self, $userinfo) = @_;
 542     my $username = $userinfo->{username};
 543
 544     throw( "Need to specify a username for deactivation" ) unless $username;
 545
 546     my $user = $self->find_user({ username => $username });
 547     throw( "User $username not found" ) unless $user;
 548
 549     $user->active(0);
 550     foreach my $tradition (@{ $user->traditions }) {
 551         ## Not implemented yet
 552         # $tradition->public(0);
 553     }
 554
 555     ## Should we be using Text::Tradition::Directory also?
 556     $self->update(@{ $user->traditions });
 557
 558     $self->update($user);
 559
 560     return $user;
 561 }
 562
 563 =head2 reactivate_user( $userinfo )
 564
 565 Takes a hashref of C<username>.
 566
 567 Returns the user object if already activated. Activates (sets the
 568 active flag to true (1)), updates the storage and returns the user.
 569
 570 Returns undef if the user is not found.
 571
 572 =cut
 573
 574 sub reactivate_user {
 575     my ($self, $userinfo) = @_;
 576     my $username = $userinfo->{username};
 577
 578     throw( "Need to specify a username for reactivation" ) unless $username;
 579
 580     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 581     throw( "User $username not found" ) unless $user;
 582
 583     return $user if $user->active;
 584
 585     $user->active(1);
 586     $self->update($user);
 587
 588     return $user;
 589 }
 590
 591 =head2 delete_user( $userinfo )
 592
 593 CAUTION: Deletes actual data!
 594
 595 Takes a hashref of C<username>.
 596
 597 Returns undef if the user doesn't exist.
 598
 599 Removes the user from the store and returns 1.
 600
 601 =cut
 602
 603 sub delete_user {
 604     my ($self, $userinfo) = @_;
 605     my $username = $userinfo->{username};
 606
 607     throw( "Need to specify a username for deletion" ) unless $username;
 608
 609     my $user = $self->find_user({ username => $username });
 610     throw( "User $username not found" ) unless $user;
 611
 612     ## Should we be using Text::Tradition::Directory for this bit?
 613     $self->delete( @{ $user->traditions });
 614
 615     ## Poof, gone.
 616     $self->delete($user);
 617
 618     return 1;
 619 }
 620
 621 =head2 validate_password( $password )
 622
 623 Takes a password string. Returns true if it is longer than
 624 L</MIN_PASS_LEN>, false otherwise.
 625
 626 Used internally by L</add_user>.
 627
 628 =cut
 629
 630 sub validate_password {
 631     my ($self, $password) = @_;
 632
 633     return if !$password;
 634     return if length($password) < $self->MIN_PASS_LEN;
 635
 636     return 1;
 637 }
 638
 639 =head2 user_traditionlist( $user )
 640
 641 Returns a tradition list (see specification above) but containing only
 642 those traditions visible to the specified user.  If $user is the string
 643 'public', returns only publicly-viewable traditions.
 644
 645 =cut
 646
 647 sub user_traditionlist {
 648     my ($self, $user) = @_;
 649
 650     my @tlist;
 651     if(ref $user && $user->is_admin) {
 652         ## Admin sees all
 653         return $self->traditionlist();
 654     } elsif(ref $user) {
 655         ## We have a user object already, so just fetch its traditions and use tose
 656         foreach my $t (@{ $user->traditions }) {
 657             push( @tlist, { 'id' => $self->object_to_id( $t ),
 658                             'name' => $t->name } );
 659         }
 660         return @tlist;
 661     } elsif($user ne 'public') {
 662         die "Passed neither a user object nor 'public' to user_traditionlist";
 663     }
 664
 665     ## Search for all traditions which allow public viewing
 666         my @list = grep { $_->{public} } $self->traditionlist();
 667         return @list;
 668 }
 669
 670 1;
 671
 672 =head1 LICENSE
 673
 674 This package is free software and is provided "as is" without express
 675 or implied warranty.  You can redistribute it and/or modify it under
 676 the same terms as Perl itself.
 677
 678 =head1 AUTHORS
 679
 680 Tara L Andrews E<lt>aurum@cpan.orgE<gt> (initial release)
 681
 682 Shadowcat Systems L<http://www.scsys.co.uk/> (user functionality; making it all work)
 683