lib/Text/Tradition/Directory.pm

   1 package Text::Tradition::Directory;
   2
   3 use strict;
   4 use warnings;
   5 use Moose;
   6 use DBI;
   7 use Encode qw/ decode_utf8 /;
   8 use KiokuDB::GC::Naive;
   9 use KiokuDB::TypeMap;
  10 use KiokuDB::TypeMap::Entry::Naive;
  11 use Text::Tradition::Error;
  12
  13 ## users
  14 use KiokuX::User::Util qw(crypt_password);
  15 use Text::Tradition::User;
  16
  17 extends 'KiokuX::Model';
  18
  19 =head1 NAME
  20
  21 Text::Tradition::Directory - a KiokuDB interface for storing and retrieving traditions
  22
  23 =head1 SYNOPSIS
  24
  25   use Text::Tradition::Directory;
  26   my $d = Text::Tradition::Directory->new(
  27     'dsn' => 'dbi:SQLite:mytraditions.db',
  28     'extra_args' => { 'create' => 1 },
  29   );
  30
  31   my $tradition = Text::Tradition->new( @args );
  32   my $stemma = $tradition->add_stemma( dotfile => $dotfile );
  33   $d->save_tradition( $tradition );
  34
  35   foreach my $id ( $d->traditions ) {
  36         print $d->tradition( $id )->name;
  37   }
  38
  39   ## Users:
  40   my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
  41   my $newuser = $userstore->add_user({ username => 'fred',
  42                                        password => 'somepassword' });
  43
  44   my $fetchuser = $userstore->find_user({ username => 'fred' });
  45   if($fetchuser->check_password('somepassword')) {
  46      ## login user or .. whatever
  47   }
  48
  49   my $user = $userstore->deactivate_user({ username => 'fred' });
  50   if(!$user->active) {
  51     ## shouldnt be able to login etc
  52   }
  53
  54 =head1 DESCRIPTION
  55
  56 Text::Tradition::Directory is an interface for storing and retrieving text traditions and all their data, including an associated stemma hypothesis.  It is an instantiation of a KiokuDB::Model, storing traditions and associated stemmas by UUID.
  57
  58 =head1 ATTRIBUTES
  59
  60 =head2 MIN_PASS_LEN
  61
  62 Constant for the minimum password length when validating passwords,
  63 defaults to "8".
  64
  65 =cut
  66
  67 has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
  68
  69 =head1 METHODS
  70
  71 =head2 new
  72
  73 Returns a Directory object.
  74
  75 =head2 traditionlist
  76
  77 Returns a hashref mapping of ID => name for all traditions in the directory.
  78
  79 =head2 tradition( $id )
  80
  81 Returns the Text::Tradition object of the given ID.
  82
  83 =head2 save( $tradition )
  84
  85 Writes the given tradition to the database, returning its ID.
  86
  87 =head2 delete( $tradition )
  88
  89 Deletes the given tradition object from the database.
  90 WARNING!! Garbage collection does not yet work. Use this sparingly.
  91
  92 =begin testing
  93
  94 use TryCatch;
  95 use File::Temp;
  96 use Text::Tradition;
  97 use_ok 'Text::Tradition::Directory';
  98
  99 my $fh = File::Temp->new();
 100 my $file = $fh->filename;
 101 $fh->close;
 102 my $dsn = "dbi:SQLite:dbname=$file";
 103 my $uuid;
 104 my $t = Text::Tradition->new(
 105         'name'  => 'inline',
 106         'input' => 'Tabular',
 107         'file'  => 't/data/simple.txt',
 108         );
 109
 110 {
 111         my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
 112                 'extra_args' => { 'create' => 1 } );
 113         is( ref $d, 'Text::Tradition::Directory', "Got directory object" );
 114
 115         my $scope = $d->new_scope;
 116         $uuid = $d->save( $t );
 117         ok( $uuid, "Saved test tradition" );
 118
 119         my $s = $t->add_stemma( dotfile => 't/data/simple.dot' );
 120         ok( $d->save( $t ), "Updated tradition with stemma" );
 121         is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" );
 122         is( $d->tradition( $uuid )->stemma(0), $s, "...and it has the correct stemma" );
 123         try {
 124                 $d->save( $s );
 125         } catch( Text::Tradition::Error $e ) {
 126                 is( $e->ident, 'database error', "Got exception trying to save stemma directly" );
 127                 like( $e->message, qr/Cannot directly save non-Tradition object/,
 128                         "Exception has correct message" );
 129         }
 130 }
 131 my $nt = Text::Tradition->new(
 132         'name' => 'CX',
 133         'input' => 'CollateX',
 134         'file' => 't/data/Collatex-16.xml',
 135         );
 136 is( ref( $nt ), 'Text::Tradition', "Made new tradition" );
 137
 138 {
 139         my $f = Text::Tradition::Directory->new( 'dsn' => $dsn );
 140         my $scope = $f->new_scope;
 141         is( scalar $f->traditionlist, 1, "Directory index has our tradition" );
 142         my $nuuid = $f->save( $nt );
 143         ok( $nuuid, "Stored second tradition" );
 144         my @tlist = $f->traditionlist;
 145         is( scalar @tlist, 2, "Directory index has both traditions" );
 146         my $tf = $f->tradition( $uuid );
 147         my( $tlobj ) = grep { $_->{'id'} eq $uuid } @tlist;
 148         is( $tlobj->{'name'}, $tf->name, "Directory index has correct tradition name" );
 149         is( $tf->name, $t->name, "Retrieved the tradition from a new directory" );
 150         my $sid = $f->object_to_id( $tf->stemma(0) );
 151         try {
 152                 $f->tradition( $sid );
 153         } catch( Text::Tradition::Error $e ) {
 154                 is( $e->ident, 'database error', "Got exception trying to fetch stemma directly" );
 155                 like( $e->message, qr/not a Text::Tradition/, "Exception has correct message" );
 156         }
 157         try {
 158                 $f->delete( $sid );
 159         } catch( Text::Tradition::Error $e ) {
 160                 is( $e->ident, 'database error', "Got exception trying to delete stemma directly" );
 161                 like( $e->message, qr/Cannot directly delete non-Tradition object/,
 162                         "Exception has correct message" );
 163         }
 164
 165         $f->delete( $uuid );
 166         ok( !$f->exists( $uuid ), "Object is deleted from DB" );
 167         ok( !$f->exists( $sid ), "Object stemma also deleted from DB" );
 168         is( scalar $f->traditionlist, 1, "Object is deleted from index" );
 169 }
 170
 171 {
 172         my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
 173         my $scope = $g->new_scope;
 174         is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
 175         my $ntobj = $g->tradition( 'CX' );
 176         my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
 177         my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
 178         is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
 179 }
 180
 181 =end testing
 182
 183 =cut
 184 use Text::Tradition::TypeMap::Entry;
 185
 186 has +typemap => (
 187   is      => 'rw',
 188   isa     => 'KiokuDB::TypeMap',
 189   default => sub {
 190     KiokuDB::TypeMap->new(
 191       isa_entries => {
 192         "Text::Tradition" =>
 193           KiokuDB::TypeMap::Entry::Naive->new(),
 194         "Graph" => Text::Tradition::TypeMap::Entry->new(),
 195         "Graph::AdjacencyMap" => Text::Tradition::TypeMap::Entry->new(),
 196         "Set::Scalar" => Text::Tradition::TypeMap::Entry->new(),
 197       }
 198     );
 199   },
 200 );
 201
 202 # Push some columns into the extra_args
 203 around BUILDARGS => sub {
 204         my $orig = shift;
 205         my $class = shift;
 206         my $args;
 207         if( @_ == 1 ) {
 208                 $args = $_[0];
 209         } else {
 210                 $args = { @_ };
 211         }
 212         if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
 213                 my @column_args = ( 'columns',
 214                         [ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 } ] );
 215                 my $ea = $args->{'extra_args'};
 216                 if( ref( $ea ) eq 'ARRAY' ) {
 217                         push( @$ea, @column_args );
 218                 } elsif( ref( $ea ) eq 'HASH' ) {
 219                         $ea = { %$ea, @column_args };
 220                 } else {
 221                         $ea = { @column_args };
 222                 }
 223                 $args->{'extra_args'} = $ea;
 224         }
 225         return $class->$orig( $args );
 226 };
 227
 228 ## These checks don't cover store($id, $obj)
 229 # before [ qw/ store update insert delete / ] => sub {
 230 before [ qw/ delete / ] => sub {
 231         my $self = shift;
 232         my @nontrad;
 233         foreach my $obj ( @_ ) {
 234                 if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition'
 235             && ref ($obj) ne 'Text::Tradition::User' ) {
 236                         # Is it an id => Tradition hash?
 237                         if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
 238                                 my( $k ) = keys %$obj;
 239                                 next if ref( $obj->{$k} ) eq 'Text::Tradition';
 240                         }
 241                         push( @nontrad, $obj );
 242                 }
 243         }
 244         if( @nontrad ) {
 245                 throw( "Cannot directly save non-Tradition object of type "
 246                         . ref( $nontrad[0] ) );
 247         }
 248 };
 249
 250 # TODO Garbage collection doesn't work. Suck it up and live with the
 251 # inflated DB.
 252 after delete => sub {
 253         my $self = shift;
 254         my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
 255         $self->directory->backend->delete( $gc->garbage->members );
 256 };
 257
 258 sub save {
 259         my $self = shift;
 260         return $self->store( @_ );
 261 }
 262
 263 sub tradition {
 264         my( $self, $id ) = @_;
 265         my $obj = $self->lookup( $id );
 266         unless( $obj ) {
 267                 # Try looking up by name.
 268                 foreach my $item ( $self->traditionlist ) {
 269                         if( $item->{'name'} eq $id ) {
 270                                 $obj = $self->lookup( $item->{'id'} );
 271                                 last;
 272                         }
 273                 }
 274         }
 275         if( $obj && ref( $obj ) ne 'Text::Tradition' ) {
 276                 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
 277         }
 278         return $obj;
 279 }
 280
 281 sub user_traditionlist {
 282     my ($self, $user) = @_;
 283
 284     my @tlist;
 285     if(ref $user && $user->is_admin) {
 286         ## Admin sees all
 287         return $self->traditionlist();
 288     } elsif(ref $user) {
 289         ## We have a user object already, so just fetch its traditions and use tose
 290         foreach my $t (@{ $user->traditions }) {
 291             push( @tlist, { 'id' => $self->object_to_id( $t ),
 292                             'name' => $t->name } );
 293         }
 294         return @tlist;
 295     } elsif($user ne 'public') {
 296         die "Passed neither a user object nor 'public' to user_traditionlist";
 297     }
 298
 299     ## Search for all traditions which allow public viewing
 300     ## When they exist!
 301 ## This needs to be more sophisticated, probably needs Search::GIN
 302 #    my $list = $self->search({ public => 1 });
 303
 304     ## For now, just fetch all
 305     ## (could use all_objects or grep down there?)
 306     return $self->traditionlist();
 307 }
 308
 309 sub traditionlist {
 310         my $self = shift;
 311     my ($user) = @_;
 312
 313     return $self->user_traditionlist($user) if($user);
 314
 315         my @tlist;
 316         # If we are using DBI, we can do it the easy way; if not, the hard way.
 317         # Easy way still involves making a separate DBI connection. Ew.
 318         if( $self->dsn =~ /^dbi:(\w+):/ ) {
 319                 my $dbtype = $1;
 320                 my @connection = @{$self->directory->backend->connect_info};
 321                 # Get rid of KiokuDB-specific arg
 322                 pop @connection if scalar @connection > 4;
 323                 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
 324                 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
 325                 my $dbh = DBI->connect( @connection );
 326                 my $q = $dbh->prepare( 'SELECT id, name from entries WHERE class = "Text::Tradition"' );
 327                 $q->execute();
 328                 while( my @row = $q->fetchrow_array ) {
 329                         my( $id, $name ) = @row;
 330                         # Horrible horrible hack
 331                         $name = decode_utf8( $name ) if $dbtype eq 'mysql';
 332                         push( @tlist, { 'id' => $row[0], 'name' => $row[1] } );
 333                 }
 334         } else {
 335                 $self->scan( sub { my $o = shift;
 336                                                    push( @tlist, { 'id' => $self->object_to_id( $o ),
 337                                                                                    'name' => $o->name } ) } );
 338         }
 339         return @tlist;
 340 }
 341
 342 sub throw {
 343         Text::Tradition::Error->throw(
 344                 'ident' => 'database error',
 345                 'message' => $_[0],
 346                 );
 347 }
 348
 349
 350 # has 'directory' => (
 351 #     is => 'rw',
 352 #     isa => 'KiokuX::Model',
 353 #     handles => []
 354 #     );
 355
 356 ## TODO: Some of these methods should probably optionally take $user objects
 357 ## instead of hashrefs.
 358
 359 ## It also occurs to me that all these methods don't need to be named
 360 ## XX_user, but leaving that way for now incase we merge this code
 361 ## into ::Directory for one-store.
 362
 363 ## To die or not to die, on error, this is the question.
 364
 365 =head2 add_user
 366
 367 Takes a hashref of C<username>, C<password>.
 368
 369 Create a new user object, store in the KiokuDB backend, and return it.
 370
 371 =cut
 372
 373 sub add_user {
 374     my ($self, $userinfo) = @_;
 375
 376     my $username = $userinfo->{username};
 377     my $password = $userinfo->{password};
 378     my $role = $userinfo->{role} || 'user';
 379
 380         throw( "No username given" ) unless $username;
 381         throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
 382                 . " characters long" )
 383                 unless ( $self->validate_password($password) || $username =~ /^https?:/ );
 384
 385     my $user = Text::Tradition::User->new(
 386         id => $username,
 387         password => ($password ? crypt_password($password) : ''),
 388         email => ($userinfo->{email} ? $userinfo->{email} : $username),
 389         role => $role,
 390     );
 391
 392     $self->store($user->kiokudb_object_id, $user);
 393
 394     return $user;
 395 }
 396
 397 sub create_user {
 398     my ($self, $userinfo) = @_;
 399
 400     ## No username means probably an OpenID based user
 401     if(!exists $userinfo->{username}) {
 402         extract_openid_data($userinfo);
 403     }
 404
 405     return $self->add_user($userinfo);
 406 }
 407
 408 ## Not quite sure where this method should be.. Auth /
 409 ## Credential::OpenID just pass us back the chunk of extension data
 410 sub extract_openid_data {
 411     my ($userinfo) = @_;
 412
 413     ## Spec says SHOULD use url as identifier
 414     $userinfo->{username} = $userinfo->{url};
 415
 416     ## Use email addy as display if available
 417     if(exists $userinfo->{extensions} &&
 418          exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
 419          defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
 420         ## Somewhat ugly attribute extension reponse, contains
 421         ## google-email string which we can use as the id
 422
 423         $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
 424     }
 425
 426     return;
 427 }
 428
 429 =head2 find_user
 430
 431 Takes a hashref of C<username>, and possibly openIDish results from
 432 L<Net::OpenID::Consumer>.
 433
 434 Fetches the user object for the given username and returns it.
 435
 436 =cut
 437
 438 sub find_user {
 439     my ($self, $userinfo) = @_;
 440
 441     ## No username means probably an OpenID based user
 442     if(!exists $userinfo->{username}) {
 443         extract_openid_data($userinfo);
 444     }
 445
 446     my $username = $userinfo->{username};
 447
 448     ## No logins if user is deactivated (use lookup to fetch to re-activate)
 449     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 450     return if(!$user || !$user->active);
 451
 452 #    print STDERR "Found user, $username, email is :", $user->email, ":\n";
 453
 454     return $user;
 455 }
 456
 457 =head2 modify_user
 458
 459 Takes a hashref of C<username> and C<password> (same as add_user).
 460
 461 Retrieves the user, and updates it with the new information. Username
 462 changing is not currently supported.
 463
 464 Returns the updated user object, or undef if not found.
 465
 466 =cut
 467
 468 sub modify_user {
 469     my ($self, $userinfo) = @_;
 470     my $username = $userinfo->{username};
 471     my $password = $userinfo->{password};
 472     my $role = $userinfo->{role};
 473
 474     throw( "Missing username or bad password" )
 475         unless $username && $self->validate_password($password);
 476
 477     my $user = $self->find_user({ username => $username });
 478     throw( "Could not find user $username" ) unless $user;
 479
 480     if($password) {
 481         $user->password(crypt_password($password));
 482     }
 483     if($role) {
 484         $user->role($role);
 485     }
 486
 487     $self->update($user);
 488
 489     return $user;
 490 }
 491
 492 =head2 deactivate_user
 493
 494 Takes a hashref of C<username>.
 495
 496 Sets the users C<active> flag to false (0), and sets all traditions
 497 assigned to them to non-public, updates the storage and returns the
 498 deactivated user.
 499
 500 Returns undef if user not found.
 501
 502 =cut
 503
 504 sub deactivate_user {
 505     my ($self, $userinfo) = @_;
 506     my $username = $userinfo->{username};
 507
 508     throw( "Need to specify a username for deactivation" ) unless $username;
 509
 510     my $user = $self->find_user({ username => $username });
 511     throw( "User $username not found" ) unless $user;
 512
 513     $user->active(0);
 514     foreach my $tradition (@{ $user->traditions }) {
 515         ## Not implemented yet
 516         # $tradition->public(0);
 517     }
 518
 519     ## Should we be using Text::Tradition::Directory also?
 520     $self->update(@{ $user->traditions });
 521
 522     $self->update($user);
 523
 524     return $user;
 525 }
 526
 527 =head2 reactivate_user
 528
 529 Takes a hashref of C<username>.
 530
 531 Returns the user object if already activated. Activates (sets the
 532 active flag to true (1)), updates the storage and returns the user.
 533
 534 Returns undef if the user is not found.
 535
 536 =cut
 537
 538 sub reactivate_user {
 539     my ($self, $userinfo) = @_;
 540     my $username = $userinfo->{username};
 541
 542     throw( "Need to specify a username for reactivation" ) unless $username;
 543
 544     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 545     throw( "User $username not found" ) unless $user;
 546
 547     return $user if $user->active;
 548
 549     $user->active(1);
 550     $self->update($user);
 551
 552     return $user;
 553 }
 554
 555 =head2 delete_user
 556
 557 CAUTION: Deletes actual data!
 558
 559 Takes a hashref of C<username>.
 560
 561 Returns undef if the user doesn't exist.
 562
 563 Removes the user from the store and returns 1.
 564
 565 =cut
 566
 567 sub delete_user {
 568     my ($self, $userinfo) = @_;
 569     my $username = $userinfo->{username};
 570
 571     throw( "Need to specify a username for deletion" ) unless $username;
 572
 573     my $user = $self->find_user({ username => $username });
 574     throw( "User $username not found" ) unless $user;
 575
 576     ## Should we be using Text::Tradition::Directory for this bit?
 577     $self->delete( @{ $user->traditions });
 578
 579     ## Poof, gone.
 580     $self->delete($user);
 581
 582     return 1;
 583 }
 584
 585 =head2 validate_password
 586
 587 Takes a password string. Returns true if it is longer than
 588 L</MIN_PASS_LEN>, false otherwise.
 589
 590 Used internally by L</add_user>.
 591
 592 =cut
 593
 594 sub validate_password {
 595     my ($self, $password) = @_;
 596
 597     return if !$password;
 598     return if length($password) < $self->MIN_PASS_LEN;
 599
 600     return 1;
 601 }
 602
 603 1;
 604
 605 =head1 LICENSE
 606
 607 This package is free software and is provided "as is" without express
 608 or implied warranty.  You can redistribute it and/or modify it under
 609 the same terms as Perl itself.
 610
 611 =head1 AUTHOR
 612
 613 Tara L Andrews E<lt>aurum@cpan.orgE<gt>