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 =head1 DESCRIPTION
  40
  41 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.
  42
  43 =head1 METHODS
  44
  45 =head2 new
  46
  47 Returns a Directory object.
  48
  49 =head2 traditionlist
  50
  51 Returns a hashref mapping of ID => name for all traditions in the directory.
  52
  53 =head2 tradition( $id )
  54
  55 Returns the Text::Tradition object of the given ID.
  56
  57 =head2 save( $tradition )
  58
  59 Writes the given tradition to the database, returning its ID.
  60
  61 =head2 delete( $tradition )
  62
  63 Deletes the given tradition object from the database.
  64 WARNING!! Garbage collection does not yet work. Use this sparingly.
  65
  66 =begin testing
  67
  68 use TryCatch;
  69 use File::Temp;
  70 use Text::Tradition;
  71 use_ok 'Text::Tradition::Directory';
  72
  73 my $fh = File::Temp->new();
  74 my $file = $fh->filename;
  75 $fh->close;
  76 my $dsn = "dbi:SQLite:dbname=$file";
  77 my $uuid;
  78 my $t = Text::Tradition->new(
  79         'name'  => 'inline',
  80         'input' => 'Tabular',
  81         'file'  => 't/data/simple.txt',
  82         );
  83
  84 {
  85         my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
  86                 'extra_args' => { 'create' => 1 } );
  87         is( ref $d, 'Text::Tradition::Directory', "Got directory object" );
  88
  89         my $scope = $d->new_scope;
  90         $uuid = $d->save( $t );
  91         ok( $uuid, "Saved test tradition" );
  92
  93         my $s = $t->add_stemma( dotfile => 't/data/simple.dot' );
  94         ok( $d->save( $t ), "Updated tradition with stemma" );
  95         is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" );
  96         is( $d->tradition( $uuid )->stemma(0), $s, "...and it has the correct stemma" );
  97         try {
  98                 $d->save( $s );
  99         } catch( Text::Tradition::Error $e ) {
 100                 is( $e->ident, 'database error', "Got exception trying to save stemma directly" );
 101                 like( $e->message, qr/Cannot directly save non-Tradition object/,
 102                         "Exception has correct message" );
 103         }
 104 }
 105 my $nt = Text::Tradition->new(
 106         'name' => 'CX',
 107         'input' => 'CollateX',
 108         'file' => 't/data/Collatex-16.xml',
 109         );
 110 is( ref( $nt ), 'Text::Tradition', "Made new tradition" );
 111
 112 {
 113         my $f = Text::Tradition::Directory->new( 'dsn' => $dsn );
 114         my $scope = $f->new_scope;
 115         is( scalar $f->traditionlist, 1, "Directory index has our tradition" );
 116         my $nuuid = $f->save( $nt );
 117         ok( $nuuid, "Stored second tradition" );
 118         my @tlist = $f->traditionlist;
 119         is( scalar @tlist, 2, "Directory index has both traditions" );
 120         my $tf = $f->tradition( $uuid );
 121         my( $tlobj ) = grep { $_->{'id'} eq $uuid } @tlist;
 122         is( $tlobj->{'name'}, $tf->name, "Directory index has correct tradition name" );
 123         is( $tf->name, $t->name, "Retrieved the tradition from a new directory" );
 124         my $sid = $f->object_to_id( $tf->stemma(0) );
 125         try {
 126                 $f->tradition( $sid );
 127         } catch( Text::Tradition::Error $e ) {
 128                 is( $e->ident, 'database error', "Got exception trying to fetch stemma directly" );
 129                 like( $e->message, qr/not a Text::Tradition/, "Exception has correct message" );
 130         }
 131         try {
 132                 $f->delete( $sid );
 133         } catch( Text::Tradition::Error $e ) {
 134                 is( $e->ident, 'database error', "Got exception trying to delete stemma directly" );
 135                 like( $e->message, qr/Cannot directly delete non-Tradition object/,
 136                         "Exception has correct message" );
 137         }
 138
 139         $f->delete( $uuid );
 140         ok( !$f->exists( $uuid ), "Object is deleted from DB" );
 141         ok( !$f->exists( $sid ), "Object stemma also deleted from DB" );
 142         is( scalar $f->traditionlist, 1, "Object is deleted from index" );
 143 }
 144
 145 {
 146         my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
 147         my $scope = $g->new_scope;
 148         is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
 149         my $ntobj = $g->tradition( 'CX' );
 150         my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
 151         my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
 152         is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
 153 }
 154
 155 =end testing
 156
 157 =cut
 158
 159 has +typemap => (
 160         is => 'rw',
 161         isa => 'KiokuDB::TypeMap',
 162         default => sub {
 163                 KiokuDB::TypeMap->new(
 164                         isa_entries => {
 165                                 "Graph" => KiokuDB::TypeMap::Entry::Naive->new,
 166                                 "Graph::AdjacencyMap" => KiokuDB::TypeMap::Entry::Naive->new,
 167                         }
 168                 );
 169         },
 170 );
 171
 172 # Push some columns into the extra_args
 173 around BUILDARGS => sub {
 174         my $orig = shift;
 175         my $class = shift;
 176         my $args;
 177         if( @_ == 1 ) {
 178                 $args = $_[0];
 179         } else {
 180                 $args = { @_ };
 181         }
 182         if( $args->{'dsn'} =~ /^dbi/ ) { # We're using Backend::DBI
 183                 my @column_args = ( 'columns',
 184                         [ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 } ] );
 185                 my $ea = $args->{'extra_args'};
 186                 if( ref( $ea ) eq 'ARRAY' ) {
 187                         push( @$ea, @column_args );
 188                 } elsif( ref( $ea ) eq 'HASH' ) {
 189                         $ea = { %$ea, @column_args };
 190                 } else {
 191                         $ea = { @column_args };
 192                 }
 193                 $args->{'extra_args'} = $ea;
 194         }
 195         return $class->$orig( $args );
 196 };
 197
 198 before [ qw/ store update insert delete / ] => sub {
 199         my $self = shift;
 200         my @nontrad;
 201         foreach my $obj ( @_ ) {
 202 #               if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition' ) {
 203
 204                 if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition'
 205             && ref ($obj) ne 'Text::Tradition::User' ) {
 206                         # Is it an id => Tradition hash?
 207                         if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
 208                                 my( $k ) = keys %$obj;
 209                                 next if ref( $obj->{$k} ) eq 'Text::Tradition';
 210                         }
 211                         push( @nontrad, $obj );
 212                 }
 213         }
 214         if( @nontrad ) {
 215                 throw( "Cannot directly save non-Tradition object of type "
 216                         . ref( $nontrad[0] ) );
 217         }
 218 };
 219
 220 # TODO Garbage collection doesn't work. Suck it up and live with the
 221 # inflated DB.
 222 # after delete => sub {
 223 #       my $self = shift;
 224 #       my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
 225 #       $self->directory->backend->delete( $gc->garbage->members );
 226 # };
 227
 228 sub save {
 229         my $self = shift;
 230         return $self->store( @_ );
 231 }
 232
 233 sub tradition {
 234         my( $self, $id ) = @_;
 235         my $obj = $self->lookup( $id );
 236         unless( $obj ) {
 237                 # Try looking up by name.
 238                 foreach my $item ( $self->traditionlist ) {
 239                         if( $item->{'name'} eq $id ) {
 240                                 $obj = $self->lookup( $item->{'id'} );
 241                                 last;
 242                         }
 243                 }
 244         }
 245         if( $obj && ref( $obj ) ne 'Text::Tradition' ) {
 246                 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
 247         }
 248         return $obj;
 249 }
 250
 251 sub traditionlist {
 252         my $self = shift;
 253         # If we are using DBI, we can do it the easy way; if not, the hard way.
 254         # Easy way still involves making a separate DBI connection. Ew.
 255         my @tlist;
 256         if( $self->dsn =~ /^dbi:(\w+):/ ) {
 257                 my $dbtype = $1;
 258                 my @connection = @{$self->directory->backend->connect_info};
 259                 # Get rid of KiokuDB-specific arg
 260                 pop @connection if scalar @connection > 4;
 261                 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
 262                 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
 263                 my $dbh = DBI->connect( @connection );
 264                 my $q = $dbh->prepare( 'SELECT id, name from entries WHERE class = "Text::Tradition"' );
 265                 $q->execute();
 266                 while( my @row = $q->fetchrow_array ) {
 267                         my( $id, $name ) = @row;
 268                         # Horrible horrible hack
 269                         $name = decode_utf8( $name ) if $dbtype eq 'mysql';
 270                         push( @tlist, { 'id' => $row[0], 'name' => $row[1] } );
 271                 }
 272         } else {
 273                 $self->scan( sub { my $o = shift;
 274                                                    push( @tlist, { 'id' => $self->object_to_id( $o ),
 275                                                                                    'name' => $o->name } ) } );
 276         }
 277         return @tlist;
 278 }
 279
 280 sub throw {
 281         Text::Tradition::Error->throw(
 282                 'ident' => 'database error',
 283                 'message' => $_[0],
 284                 );
 285 }
 286
 287 =head1 NAME
 288
 289 Text::Tradition::UserStore - KiokuDB storage management for Users
 290
 291 =head1 SYNOPSIS
 292
 293     my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
 294     my $newuser = $userstore->add_user({ username => 'fred',
 295                                          password => 'somepassword' });
 296
 297     my $fetchuser = $userstore->find_user({ username => 'fred' });
 298     if($fetchuser->check_password('somepassword')) {
 299        ## login user or .. whatever
 300     }
 301
 302     my $user = $userstore->deactivate_user({ username => 'fred' });
 303     if(!$user->active) {
 304       ## shouldnt be able to login etc
 305     }
 306
 307 =head1 DESCRIPTION
 308
 309 A L<KiokuX::Model> for managing the storage and creation of
 310 L<Text::Tradition::User> objects. Subclass or replace this module in
 311 order to use a different source for stemmaweb users.
 312
 313 =head2 ATTRIBUTES
 314
 315 =head3 dsn
 316
 317 Inherited from KiokuX::Model - dsn for the data store we are using.
 318
 319 =head3 MIN_PASS_LEN
 320
 321 Constant for the minimum password length when validating passwords,
 322 defaults to "8".
 323
 324 =cut
 325
 326 has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
 327
 328 # has 'directory' => (
 329 #     is => 'rw',
 330 #     isa => 'KiokuX::Model',
 331 #     handles => []
 332 #     );
 333
 334 ## TODO: Some of these methods should probably optionally take $user objects
 335 ## instead of hashrefs.
 336
 337 ## It also occurs to me that all these methods don't need to be named
 338 ## XX_user, but leaving that way for now incase we merge this code
 339 ## into ::Directory for one-store.
 340
 341 ## To die or not to die, on error, this is the question.
 342
 343 =head2 METHODS
 344
 345 =head3 add_user
 346
 347 Takes a hashref of C<username>, C<password>.
 348
 349 Create a new user object, store in the KiokuDB backend, and return it.
 350
 351 =cut
 352
 353 sub add_user {
 354     my ($self, $userinfo) = @_;
 355     my $username = $userinfo->{url} || $userinfo->{username};
 356     my $password = $userinfo->{password};
 357
 358     return unless ($username =~ /^https?:/
 359                    || ($username && $self->validate_password($password))) ;
 360
 361     my $user = Text::Tradition::User->new(
 362         id => $username,
 363         password => ($password ? crypt_password($password) : ''),
 364     );
 365
 366     my $scope = $self->new_scope;
 367     $self->store($user->kiokudb_object_id, $user);
 368
 369     return $user;
 370 }
 371
 372 sub create_user {
 373     my $self = shift;
 374     return $self->add_user(@_);
 375 }
 376
 377 =head3 find_user
 378
 379 Takes a hashref of C<username>, optionally C<openid_identifier>.
 380
 381 Fetches the user object for the given username and returns it.
 382
 383 =cut
 384
 385 sub find_user {
 386     my ($self, $userinfo) = @_;
 387     ## url or display?
 388     # 'display' => 'castaway.myopenid.com',
 389     # 'url' => 'http://castaway.myopenid.com/',
 390     my $username = $userinfo->{url} || $userinfo->{username};
 391
 392     return $self->lookup(Text::Tradition::User->id_for_user($username));
 393
 394 }
 395
 396 =head3 modify_user
 397
 398 Takes a hashref of C<username> and C<password> (same as add_user).
 399
 400 Retrieves the user, and updates it with the new information. Username
 401 changing is not currently supported.
 402
 403 Returns the updated user object, or undef if not found.
 404
 405 =cut
 406
 407 sub modify_user {
 408     my ($self, $userinfo) = @_;
 409     my $username = $userinfo->{username};
 410     my $password = $userinfo->{password};
 411
 412     return unless $username && $self->validate_password($password);
 413
 414     my $scope = $self->new_scope;
 415     my $user = $self->find_user({ username => $username });
 416     return unless $user;
 417
 418     $user->password(crypt_password($password));
 419
 420     $self->update($user);
 421
 422     return $user;
 423 }
 424
 425 =head3 deactivate_user
 426
 427 Takes a hashref of C<username>.
 428
 429 Sets the users C<active> flag to false (0), and sets all traditions
 430 assigned to them to non-public, updates the storage and returns the
 431 deactivated user.
 432
 433 Returns undef if user not found.
 434
 435 =cut
 436
 437 sub deactivate_user {
 438     my ($self, $userinfo) = @_;
 439     my $username = $userinfo->{username};
 440
 441     return if !$username;
 442
 443     my $user = $self->find_user({ username => $username });
 444     return if !$user;
 445
 446     $user->active(0);
 447     foreach my $tradition (@{ $user->traditions }) {
 448         ## Not implemented yet
 449         # $tradition->public(0);
 450     }
 451     my $scope = $self->new_scope;
 452
 453     ## Should we be using Text::Tradition::Directory also?
 454     $self->update(@{ $user->traditions });
 455
 456     $self->update($user);
 457
 458     return $user;
 459 }
 460
 461 =head3 reactivate_user
 462
 463 Takes a hashref of C<username>.
 464
 465 Returns the user object if already activated. Activates (sets the
 466 active flag to true (1)), updates the storage and returns the user.
 467
 468 Returns undef if the user is not found.
 469
 470 =cut
 471
 472 sub reactivate_user {
 473     my ($self, $userinfo) = @_;
 474     my $username = $userinfo->{username};
 475
 476     return if !$username;
 477
 478     my $scope = $self->new_scope;
 479     my $user = $self->find_user({ username => $username });
 480     return if !$user;
 481
 482     return $user if $user->active;
 483
 484     $user->active(1);
 485     $self->update($user);
 486
 487     return $user;
 488 }
 489
 490 =head3 delete_user
 491
 492 CAUTION: Delets actual data!
 493
 494 Takes a hashref of C<username>.
 495
 496 Returns undef if the user doesn't exist.
 497
 498 Removes the user from the store and returns 1.
 499
 500 =cut
 501
 502 sub delete_user {
 503     my ($self, $userinfo) = @_;
 504     my $username = $userinfo->{username};
 505
 506     return if !$username;
 507
 508     my $scope = $self->new_scope;
 509     my $user = $self->find_user({ username => $username });
 510     return if !$user;
 511
 512     ## Should we be using Text::Tradition::Directory for this bit?
 513     $self->delete( @{ $user->traditions });
 514
 515     ## Poof, gone.
 516     $self->delete($user);
 517
 518     return 1;
 519 }
 520
 521 =head3 validate_password
 522
 523 Takes a password string. Returns true if it is longer than
 524 L</MIN_PASS_LEN>, false otherwise.
 525
 526 Used internally by L</add_user>.
 527
 528 =cut
 529
 530 sub validate_password {
 531     my ($self, $password) = @_;
 532
 533     return if !$password;
 534     return if length($password) < $self->MIN_PASS_LEN;
 535
 536     return 1;
 537 }
 538
 539 1;
 540
 541 =head1 LICENSE
 542
 543 This package is free software and is provided "as is" without express
 544 or implied warranty.  You can redistribute it and/or modify it under
 545 the same terms as Perl itself.
 546
 547 =head1 AUTHOR
 548
 549 Tara L Andrews E<lt>aurum@cpan.orgE<gt>