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