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