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     return unless ($username =~ /^https?:/
 380                    || ($username && $self->validate_password($password))) ;
 381
 382     my $user = Text::Tradition::User->new(
 383         id => $username,
 384         password => ($password ? crypt_password($password) : ''),
 385         email => ($userinfo->{email} ? $userinfo->{email} : $username),
 386         role => $role,
 387     );
 388
 389     $self->store($user->kiokudb_object_id, $user);
 390
 391     return $user;
 392 }
 393
 394 sub create_user {
 395     my ($self, $userinfo) = @_;
 396
 397     ## No username means probably an OpenID based user
 398     if(!exists $userinfo->{username}) {
 399         extract_openid_data($userinfo);
 400     }
 401
 402     return $self->add_user($userinfo);
 403 }
 404
 405 ## Not quite sure where this method should be.. Auth /
 406 ## Credential::OpenID just pass us back the chunk of extension data
 407 sub extract_openid_data {
 408     my ($userinfo) = @_;
 409
 410     ## Spec says SHOULD use url as identifier
 411     $userinfo->{username} = $userinfo->{url};
 412
 413     ## Use email addy as display if available
 414     if(exists $userinfo->{extensions} &&
 415          exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
 416          defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
 417         ## Somewhat ugly attribute extension reponse, contains
 418         ## google-email string which we can use as the id
 419
 420         $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
 421     }
 422
 423     return;
 424 }
 425
 426 =head2 find_user
 427
 428 Takes a hashref of C<username>, and possibly openIDish results from
 429 L<Net::OpenID::Consumer>.
 430
 431 Fetches the user object for the given username and returns it.
 432
 433 =cut
 434
 435 sub find_user {
 436     my ($self, $userinfo) = @_;
 437
 438     ## No username means probably an OpenID based user
 439     if(!exists $userinfo->{username}) {
 440         extract_openid_data($userinfo);
 441     }
 442
 443     my $username = $userinfo->{username};
 444
 445     ## No logins if user is deactivated (use lookup to fetch to re-activate)
 446     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 447     return if(!$user || !$user->active);
 448
 449     print STDERR "Found user, $username, email is :", $user->email, ":\n";
 450
 451     return $user;
 452 }
 453
 454 =head2 modify_user
 455
 456 Takes a hashref of C<username> and C<password> (same as add_user).
 457
 458 Retrieves the user, and updates it with the new information. Username
 459 changing is not currently supported.
 460
 461 Returns the updated user object, or undef if not found.
 462
 463 =cut
 464
 465 sub modify_user {
 466     my ($self, $userinfo) = @_;
 467     my $username = $userinfo->{username};
 468     my $password = $userinfo->{password};
 469     my $role = $userinfo->{role};
 470
 471     return unless $username;
 472     return if($password && !$self->validate_password($password));
 473
 474     my $user = $self->find_user({ username => $username });
 475     return unless $user;
 476
 477     if($password) {
 478         $user->password(crypt_password($password));
 479     }
 480     if($role) {
 481         $user->role($role);
 482     }
 483
 484     $self->update($user);
 485
 486     return $user;
 487 }
 488
 489 =head2 deactivate_user
 490
 491 Takes a hashref of C<username>.
 492
 493 Sets the users C<active> flag to false (0), and sets all traditions
 494 assigned to them to non-public, updates the storage and returns the
 495 deactivated user.
 496
 497 Returns undef if user not found.
 498
 499 =cut
 500
 501 sub deactivate_user {
 502     my ($self, $userinfo) = @_;
 503     my $username = $userinfo->{username};
 504
 505     return if !$username;
 506
 507     my $user = $self->find_user({ username => $username });
 508     return if !$user;
 509
 510     $user->active(0);
 511     foreach my $tradition (@{ $user->traditions }) {
 512         ## Not implemented yet
 513         # $tradition->public(0);
 514     }
 515
 516     ## Should we be using Text::Tradition::Directory also?
 517     $self->update(@{ $user->traditions });
 518
 519     $self->update($user);
 520
 521     return $user;
 522 }
 523
 524 =head2 reactivate_user
 525
 526 Takes a hashref of C<username>.
 527
 528 Returns the user object if already activated. Activates (sets the
 529 active flag to true (1)), updates the storage and returns the user.
 530
 531 Returns undef if the user is not found.
 532
 533 =cut
 534
 535 sub reactivate_user {
 536     my ($self, $userinfo) = @_;
 537     my $username = $userinfo->{username};
 538
 539     return if !$username;
 540
 541     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 542     return if !$user;
 543
 544     return $user if $user->active;
 545
 546     $user->active(1);
 547     $self->update($user);
 548
 549     return $user;
 550 }
 551
 552 =head2 delete_user
 553
 554 CAUTION: Deletes actual data!
 555
 556 Takes a hashref of C<username>.
 557
 558 Returns undef if the user doesn't exist.
 559
 560 Removes the user from the store and returns 1.
 561
 562 =cut
 563
 564 sub delete_user {
 565     my ($self, $userinfo) = @_;
 566     my $username = $userinfo->{username};
 567
 568     return if !$username;
 569
 570     my $user = $self->find_user({ username => $username });
 571     return if !$user;
 572
 573     ## Should we be using Text::Tradition::Directory for this bit?
 574     $self->delete( @{ $user->traditions });
 575
 576     ## Poof, gone.
 577     $self->delete($user);
 578
 579     return 1;
 580 }
 581
 582 =head2 validate_password
 583
 584 Takes a password string. Returns true if it is longer than
 585 L</MIN_PASS_LEN>, false otherwise.
 586
 587 Used internally by L</add_user>.
 588
 589 =cut
 590
 591 sub validate_password {
 592     my ($self, $password) = @_;
 593
 594     return if !$password;
 595     return if length($password) < $self->MIN_PASS_LEN;
 596
 597     return 1;
 598 }
 599
 600 1;
 601
 602 =head1 LICENSE
 603
 604 This package is free software and is provided "as is" without express
 605 or implied warranty.  You can redistribute it and/or modify it under
 606 the same terms as Perl itself.
 607
 608 =head1 AUTHOR
 609
 610 Tara L Andrews E<lt>aurum@cpan.orgE<gt>