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