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