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