persistence/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/ encode decode_utf8 /;
   8 use KiokuDB::GC::Naive;
   9 use KiokuDB::TypeMap;
  10 use KiokuDB::TypeMap::Entry::Naive;
  11 use Safe::Isa;
  12 use Text::Tradition::Error;
  13
  14 ## users
  15 use KiokuX::User::Util qw(crypt_password);
  16 use Text::Tradition::Store;
  17 use Text::Tradition::User;
  18 use Text::Tradition::TypeMap::Entry;
  19
  20 extends 'KiokuX::Model';
  21
  22 use vars qw/ $VERSION /;
  23 $VERSION = "1.2";
  24
  25 =head1 NAME
  26
  27 Text::Tradition::Directory - a KiokuDB interface for storing and retrieving
  28 traditions and their owners
  29
  30 =head1 SYNOPSIS
  31
  32   use Text::Tradition::Directory;
  33   my $d = Text::Tradition::Directory->new(
  34     'dsn' => 'dbi:SQLite:mytraditions.db',
  35     'extra_args' => { 'create' => 1 },
  36   );
  37
  38   my $tradition = Text::Tradition->new( @args );
  39   my $stemma = $tradition->add_stemma( dotfile => $dotfile ); # if Analysis module installed
  40   $d->save_tradition( $tradition );
  41
  42   foreach my $id ( $d->traditions ) {
  43         print $d->tradition( $id )->name;
  44   }
  45
  46   ## Users:
  47   my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
  48   my $newuser = $userstore->add_user({ username => 'fred',
  49                                        password => 'somepassword' });
  50
  51   my $fetchuser = $userstore->find_user({ username => 'fred' });
  52   if($fetchuser->check_password('somepassword')) {
  53      ## login user or .. whatever
  54   }
  55
  56   my $user = $userstore->deactivate_user({ username => 'fred' });
  57   if(!$user->active) {
  58     ## shouldnt be able to login etc
  59   }
  60
  61 =head1 DESCRIPTION
  62
  63 Text::Tradition::Directory is an interface for storing and retrieving text
  64 traditions and all their data, including an associated stemma hypothesis
  65 and a user who has ownership rights to the tradition data. It is an
  66 instantiation of a KiokuDB::Model, storing traditions and associated
  67 stemmas by UUID.
  68
  69 The Text::Tradition::Directory package also includes the
  70 L<Text::Tradition::User> class for user objects, and the
  71 L<Text::Tradition::Ownership> role which extends the Text::Tradition class
  72 to handle user ownership.
  73
  74 =head1 ATTRIBUTES
  75
  76 =head2 MIN_PASS_LEN
  77
  78 Constant for the minimum password length when validating passwords,
  79 defaults to "8".
  80
  81 =cut
  82
  83 has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
  84
  85 =head1 METHODS
  86
  87 =head2 new
  88
  89 Returns a Directory object.
  90
  91 =head2 traditionlist
  92
  93 Returns a hashref mapping of ID => name for all traditions in the directory.
  94
  95 =head2 tradition( $id )
  96
  97 Returns the Text::Tradition object of the given ID.
  98
  99 =head2 save( $tradition )
 100
 101 Writes the given tradition to the database, returning its ID.
 102
 103 =head2 delete( $tradition )
 104
 105 Deletes the given tradition object from the database.
 106 WARNING!! Garbage collection does not yet work. Use this sparingly.
 107
 108 =begin testing
 109
 110 use TryCatch;
 111 use File::Temp;
 112 use Safe::Isa;
 113 use Text::Tradition;
 114 use_ok 'Text::Tradition::Directory';
 115
 116 my $fh = File::Temp->new();
 117 my $file = $fh->filename;
 118 $fh->close;
 119 my $dsn = "dbi:SQLite:dbname=$file";
 120 my $uuid;
 121 my $user = 'user@example.org';
 122 my $t = Text::Tradition->new(
 123         'name'  => 'inline',
 124         'input' => 'Tabular',
 125         'file'  => 't/data/simple.txt',
 126         );
 127 my $stemma_enabled = $t->can( 'add_stemma' );
 128
 129 {
 130         my $d = Text::Tradition::Directory->new( 'dsn' => $dsn,
 131                 'extra_args' => { 'create' => 1 } );
 132         ok( $d->$_isa('Text::Tradition::Directory'), "Got directory object" );
 133
 134         my $scope = $d->new_scope;
 135         $uuid = $d->save( $t );
 136         ok( $uuid, "Saved test tradition" );
 137
 138         # Add a test user
 139         my $user = $d->add_user({ username => $user, password => 'UserPass' });
 140         $user->add_tradition( $t );
 141         $d->store( $user );
 142         is( $t->user, $user, "Assigned tradition to test user" );
 143
 144         SKIP: {
 145                 skip "Analysis package not installed", 5 unless $stemma_enabled;
 146                 my $s = $t->add_stemma( dotfile => 't/data/simple.dot' );
 147                 ok( $d->save( $t ), "Updated tradition with stemma" );
 148                 is( $d->tradition( $uuid ), $t, "Correct tradition returned for id" );
 149                 is( $d->tradition( $uuid )->stemma(0), $s, "...and it has the correct stemma" );
 150                 try {
 151                         $d->save( $s );
 152                 } catch( Text::Tradition::Error $e ) {
 153                         is( $e->ident, 'database error', "Got exception trying to save stemma directly" );
 154                         like( $e->message, qr/Cannot directly save non-Tradition object/,
 155                                 "Exception has correct message" );
 156                 }
 157         }
 158 }
 159 my $nt = Text::Tradition->new(
 160         'name' => 'CX',
 161         'input' => 'CollateX',
 162         'file' => 't/data/Collatex-16.xml',
 163         );
 164 ok( $nt->$_isa('Text::Tradition'), "Made new tradition" );
 165
 166 {
 167         my $f = Text::Tradition::Directory->new( 'dsn' => $dsn );
 168         my $scope = $f->new_scope;
 169         is( scalar $f->traditionlist, 1, "Directory index has our tradition" );
 170         my $nuuid = $f->save( $nt );
 171         ok( $nuuid, "Stored second tradition" );
 172         my @tlist = $f->traditionlist;
 173         is( scalar @tlist, 2, "Directory index has both traditions" );
 174         my $tf = $f->tradition( $uuid );
 175         my( $tlobj ) = grep { $_->{'id'} eq $uuid } @tlist;
 176         is( $tlobj->{'name'}, $tf->name, "Directory index has correct tradition name" );
 177         is( $tf->name, $t->name, "Retrieved the tradition from a new directory" );
 178         my $sid;
 179         SKIP: {
 180                 skip "Analysis package not installed", 4 unless $stemma_enabled;
 181                 $sid = $f->object_to_id( $tf->stemma(0) );
 182                 try {
 183                         $f->tradition( $sid );
 184                 } catch( Text::Tradition::Error $e ) {
 185                         is( $e->ident, 'database error', "Got exception trying to fetch stemma directly" );
 186                         like( $e->message, qr/not a Text::Tradition/, "Exception has correct message" );
 187                 }
 188                 if( $ENV{TEST_DELETION} ) {
 189                         try {
 190                                 $f->delete( $sid );
 191                         } catch( Text::Tradition::Error $e ) {
 192                                 is( $e->ident, 'database error', "Got exception trying to delete stemma directly" );
 193                                 like( $e->message, qr/Cannot directly delete non-Tradition object/,
 194                                         "Exception has correct message" );
 195                         }
 196                 }
 197         }
 198
 199         SKIP: {
 200                 skip "Set TEST_DELETION in env to test DB deletion functionality", 3
 201                         unless $ENV{TEST_DELETION};
 202                 $f->delete( $uuid );
 203                 ok( !$f->exists( $uuid ), "Object is deleted from DB" );
 204                 ok( !$f->exists( $sid ), "Object stemma also deleted from DB" ) if $stemma_enabled;
 205                 is( scalar $f->traditionlist, 1, "Object is deleted from index" );
 206         }
 207 }
 208
 209 {
 210         my $g = Text::Tradition::Directory->new( 'dsn' => $dsn );
 211         my $scope = $g->new_scope;
 212         SKIP: {
 213                 skip "Set TEST_DELETION in env to test DB deletion functionality", 1
 214                         unless $ENV{TEST_DELETION};
 215                 is( scalar $g->traditionlist, 1, "Now one object in new directory index" );
 216         }
 217         my $ntobj = $g->tradition( 'CX' );
 218         my @w1 = sort { $a->sigil cmp $b->sigil } $ntobj->witnesses;
 219         my @w2 = sort{ $a->sigil cmp $b->sigil } $nt->witnesses;
 220         is_deeply( \@w1, \@w2, "Looked up remaining tradition by name" );
 221 }
 222
 223 =end testing
 224
 225 =cut
 226 use Text::Tradition::TypeMap::Entry;
 227
 228 has +typemap => (
 229   is      => 'rw',
 230   isa     => 'KiokuDB::TypeMap',
 231   default => sub {
 232     KiokuDB::TypeMap->new(
 233       isa_entries => {
 234         # now that we fall back to YAML deflation, all attributes of
 235         # Text::Tradition will be serialized to YAML as individual objects
 236         # Except if we declare a specific entry type here
 237         "Text::Tradition" =>
 238           KiokuDB::TypeMap::Entry::MOP->new(),
 239         # We need users to be naive entries so that they hold
 240         # references to the original tradition objects, not clones
 241         "Text::Tradition::User" =>
 242           KiokuDB::TypeMap::Entry::MOP->new(),
 243         "Text::Tradition::Collation" =>
 244           KiokuDB::TypeMap::Entry::MOP->new(),
 245         "Text::Tradition::Witness" =>
 246           KiokuDB::TypeMap::Entry::MOP->new(),
 247         "Graph" => Text::Tradition::TypeMap::Entry->new(),
 248         "Set::Scalar" => Text::Tradition::TypeMap::Entry->new(),
 249       }
 250     );
 251   },
 252 );
 253
 254 has '_mysql_utf8_hack' => (
 255         is => 'ro',
 256         isa => 'Bool',
 257         default => undef,
 258 );
 259
 260 # Push some columns into the extra_args
 261 around BUILDARGS => sub {
 262         my $orig = shift;
 263         my $class = shift;
 264         my $args;
 265         if( @_ == 1 ) {
 266                 $args = $_[0];
 267         } else {
 268                 $args = { @_ };
 269         }
 270         my @column_args;
 271         if( $args->{'dsn'} =~ /^dbi:(\w+):/ ) { # We're using Backend::DBI
 272                 my $dbtype = $1;
 273                 @column_args = ( 'columns',
 274                         [ 'name' => { 'data_type' => 'varchar', 'is_nullable' => 1 },
 275                           'public' => { 'data_type' => 'bool', 'is_nullable' => 1 } ] );
 276                 if( $dbtype eq 'mysql' &&
 277                         exists $args->{extra_args}->{dbi_attrs} &&
 278                         $args->{extra_args}->{dbi_attrs}->{mysql_enable_utf8} ) {
 279                         # There is a bad interaction with MySQL in utf-8 mode.
 280                         # Work around it here.
 281                         # TODO fix the underlying storage problem
 282                         $args->{extra_args}->{dbi_attrs}->{mysql_enable_utf8} = undef;
 283                         $args->{_mysql_utf8_hack} = 1;
 284                 }
 285         }
 286         my $ea = $args->{'extra_args'};
 287         if( ref( $ea ) eq 'ARRAY' ) {
 288                 push( @$ea, @column_args );
 289         } elsif( ref( $ea ) eq 'HASH' ) {
 290                 $ea = { %$ea, @column_args };
 291         } else {
 292                 $ea = { @column_args };
 293         }
 294         $args->{'extra_args'} = $ea;
 295
 296         return $class->$orig( $args );
 297 };
 298
 299 override _build_directory => sub {
 300   my($self) = @_;
 301   Text::Tradition::Store->connect(@{ $self->_connect_args },
 302     resolver_constructor => sub {
 303       my($class) = @_;
 304       $class->new({ typemap => $self->directory->merged_typemap,
 305                     fallback_entry => Text::Tradition::TypeMap::Entry->new() });
 306   });
 307 };
 308
 309 ## These checks don't cover store($id, $obj)
 310 # before [ qw/ store update insert delete / ] => sub {
 311 before [ qw/ delete / ] => sub {
 312         my $self = shift;
 313         my @nontrad;
 314         foreach my $obj ( @_ ) {
 315                 if( ref( $obj ) && !$obj->$_isa( 'Text::Tradition' )
 316             && !$obj->$_isa('Text::Tradition::User') ) {
 317                         # Is it an id => Tradition hash?
 318                         if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
 319                                 my( $k ) = keys %$obj;
 320                                 next if $obj->{$k}->$_isa('Text::Tradition');
 321                         }
 322                         push( @nontrad, $obj );
 323                 }
 324         }
 325         if( @nontrad ) {
 326                 throw( "Cannot directly save non-Tradition object of type "
 327                         . ref( $nontrad[0] ) );
 328         }
 329 };
 330
 331 # TODO Garbage collection doesn't work. Suck it up and live with the
 332 # inflated DB.
 333 after delete => sub {
 334         my $self = shift;
 335         my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
 336         $self->directory->backend->delete( $gc->garbage->members );
 337 };
 338
 339 sub save {
 340         my $self = shift;
 341         return $self->store( @_ );
 342 }
 343
 344 sub tradition {
 345         my( $self, $id ) = @_;
 346         my $obj = $self->lookup( $id );
 347         unless( $obj ) {
 348                 # Try looking up by name.
 349                 foreach my $item ( $self->traditionlist ) {
 350                         if( $item->{'name'} eq $id ) {
 351                                 $obj = $self->lookup( $item->{'id'} );
 352                                 last;
 353                         }
 354                 }
 355         }
 356         if( $obj && !$obj->$_isa('Text::Tradition') ) {
 357                 throw( "Retrieved object is a " . ref( $obj ) . ", not a Text::Tradition" );
 358         }
 359         return $obj;
 360 }
 361
 362 sub traditionlist {
 363         my $self = shift;
 364     my ($user) = @_;
 365
 366     return $self->user_traditionlist($user) if($user);
 367         return $self->_get_object_idlist( 'Text::Tradition' );
 368 }
 369
 370 sub _get_object_idlist {
 371         my( $self, $objclass ) = @_;
 372         my @tlist;
 373         # If we are using DBI, we can do it the easy way; if not, the hard way.
 374         # Easy way still involves making a separate DBI connection. Ew.
 375         if( $self->dsn =~ /^dbi:(\w+):/ ) {
 376                 my $dbtype = $1;
 377                 my @connection = @{$self->directory->backend->connect_info};
 378                 # Get rid of KiokuDB-specific arg
 379                 pop @connection if scalar @connection > 4;
 380                 $connection[3]->{'sqlite_unicode'} = 1 if $dbtype eq 'SQLite';
 381                 $connection[3]->{'pg_enable_utf8'} = 1 if $dbtype eq 'Pg';
 382                 my $dbh = DBI->connect( @connection );
 383                 my $q = $dbh->prepare( 'SELECT id, name, public from entries WHERE class = "'
 384                         . $objclass . '"' );
 385                 $q->execute();
 386                 while( my @row = $q->fetchrow_array ) {
 387                         # Horrible horrible hack. Re-convert the name to UTF-8.
 388                         if( $self->_mysql_utf8_hack ) {
 389                                 # Convert the chars into a raw bytestring.
 390                                 my $octets = encode( 'ISO-8859-1', $row[1] );
 391                                 $row[1] = decode_utf8( $octets );
 392                         }
 393                         push( @tlist, { 'id' => $row[0], 'name' => $row[1], 'public' => $row[2] } );
 394                 }
 395         } else {
 396                 $self->scan( sub { my $o = shift;
 397                                                    push( @tlist, { 'id' => $self->object_to_id( $o ),
 398                                                                                    'name' => $o->name,
 399                                                                                    'public' => $o->public } )
 400                                                                 if( ref $o eq $objclass ) } );
 401         }
 402         return @tlist;
 403 }
 404
 405 sub throw {
 406         Text::Tradition::Error->throw(
 407                 'ident' => 'database error',
 408                 'message' => $_[0],
 409                 );
 410 }
 411
 412
 413 # has 'directory' => (
 414 #     is => 'rw',
 415 #     isa => 'KiokuX::Model',
 416 #     handles => []
 417 #     );
 418
 419 ## TODO: Some of these methods should probably optionally take $user objects
 420 ## instead of hashrefs.
 421
 422 ## It also occurs to me that all these methods don't need to be named
 423 ## XX_user, but leaving that way for now incase we merge this code
 424 ## into ::Directory for one-store.
 425
 426 =head1 USER DIRECTORY METHODS
 427
 428 =head2 add_user( $userinfo )
 429
 430 Takes a hashref of C<username>, C<password>.
 431
 432 Create a new user object, store in the KiokuDB backend, and return it.
 433
 434 =cut
 435
 436 sub add_user {
 437     my ($self, $userinfo) = @_;
 438
 439     my $username = $userinfo->{username};
 440     my $password = $userinfo->{password};
 441     my $role = $userinfo->{role} || 'user';
 442
 443     if ($userinfo->{sub}) {
 444         $username = $userinfo->{sub};
 445     }
 446
 447         throw( "No username given" ) unless $username;
 448         throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
 449                 . " characters long" )
 450                 unless ( $self->validate_password($password) || $username =~ /^https?:/  || exists ($userinfo->{openid_id}) || exists ($userinfo->{sub}));
 451
 452     my $user = Text::Tradition::User->new(
 453         id => $username,
 454         password => ($password ? crypt_password($password) : ''),
 455         email => ($userinfo->{email} ? $userinfo->{email} : $username),
 456         role => $role,
 457     );
 458
 459     $self->store($user->kiokudb_object_id, $user);
 460
 461     return $user;
 462 }
 463
 464 =head2 create_user( $userinfo )
 465
 466 Takes a hashref that can either be suitable for add_user (see above) or be
 467 a hash of OpenID user information from Credential::OpenID.
 468
 469 =cut
 470
 471 sub create_user {
 472     my ($self, $userinfo) = @_;
 473
 474     ## No username means probably an OpenID based user
 475     if(!exists $userinfo->{username}) {
 476         _extract_openid_data($userinfo);
 477     }
 478
 479     return $self->add_user($userinfo);
 480 }
 481
 482 ## Not quite sure where this method should be.. Auth /
 483 ## Credential::OpenID just pass us back the chunk of extension data
 484 sub _extract_openid_data {
 485     my ($userinfo) = @_;
 486
 487     ## Spec says SHOULD use url as identifier
 488     $userinfo->{username} = $userinfo->{url};
 489
 490     ## Use email addy as display if available
 491     if(exists $userinfo->{extensions} &&
 492          exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
 493          defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
 494         ## Somewhat ugly attribute extension reponse, contains
 495         ## google-email string which we can use as the id
 496
 497         $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
 498     }
 499
 500     return;
 501 }
 502
 503 =head2 find_user( $userinfo )
 504
 505 Takes a hashref of C<username> or C<email>, and possibly openIDish results from
 506 L<Net::OpenID::Consumer>.
 507
 508 Fetches the user object for the given username and returns it.
 509
 510 =cut
 511
 512 sub find_user {
 513     my ($self, $userinfo) = @_;
 514
 515     ## A URL field means probably an OpenID based user
 516     if( exists $userinfo->{url} ) {
 517         _extract_openid_data($userinfo);
 518     }
 519
 520     if (exists $userinfo->{sub} && exists $userinfo->{openid_id}) {
 521         return $self->_find_gplus($userinfo);
 522     }
 523
 524         my $user;
 525         if( exists $userinfo->{username} ) {
 526         my $username = $userinfo->{username};
 527                 ## No logins if user is deactivated (use lookup to fetch to re-activate)
 528                 $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 529                 ## If there is an inactive user, skip it
 530                 return if( $user && !$user->active );
 531         } elsif( exists $userinfo->{email} ) {
 532                 ## Scan the users looking for a matching email
 533                 my @matches;
 534                 $self->scan( sub { push( @matches, @_ )
 535                         if $_[0]->isa('Text::Tradition::User')
 536                         && $_[0]->email eq $userinfo->{email} } );
 537                 $user = shift @matches;
 538         }
 539 #    print STDERR "Found user, $username, email is :", $user->email, ":\n";
 540     return $user;
 541 }
 542
 543 sub _find_gplus {
 544     my ($self, $userinfo) = @_;
 545
 546     my $sub = $userinfo->{sub};
 547     my $openid = $userinfo->{openid_id};
 548     my $email = $userinfo->{email};
 549
 550     # Do we have a user with the google id already?
 551
 552     my $user = $self->find_user({
 553         username => $sub
 554     });
 555     warn "Found by google+id" if $user;
 556
 557     if ($user) {
 558         return $user;
 559     }
 560
 561     # Do we have a user with the openid?
 562
 563     $user = $self->find_user({
 564         url => $openid
 565     });
 566     warn "Found by openid" if $user;
 567     $user ||= $self->find_user({ email => $userinfo->{email} });
 568     warn "Found by email" if $user;
 569
 570     if (!$user) {
 571         return undef;
 572     }
 573
 574     my $new_user = $self->add_user({
 575             username  => $sub,
 576             password  => $user->password,
 577             role      => $user->role,
 578             active    => $user->active,
 579             sub       => $sub,
 580             openid_id => $openid,
 581             email     => $email,
 582         });
 583
 584     foreach my $t (@{ $user->traditions }) {
 585                 $user->remove_tradition($t);
 586         $new_user->add_tradition($t);
 587     }
 588     $self->update($user);
 589     $self->update($new_user);
 590
 591     # $self->delete_user({ username => $user->id });
 592     return $new_user;
 593 }
 594
 595 =head2 modify_user( $userinfo )
 596
 597 Takes a hashref of C<username> and C<password> (same as add_user).
 598
 599 Retrieves the user, and updates it with the new information. Username
 600 changing is not currently supported.
 601
 602 Returns the updated user object, or undef if not found.
 603
 604 =cut
 605
 606 sub modify_user {
 607     my ($self, $userinfo) = @_;
 608     my $username = $userinfo->{username};
 609     my $password = $userinfo->{password};
 610     my $role = $userinfo->{role};
 611
 612     throw( "Missing username" ) unless $username;
 613
 614     my $user = $self->find_user({ username => $username });
 615     throw( "Could not find user $username" ) unless $user;
 616
 617     if($password) {
 618         throw( "Bad password" ) unless $self->validate_password($password);
 619         $user->password(crypt_password($password));
 620     }
 621     if($role) {
 622         $user->role($role);
 623     }
 624
 625     $self->update($user);
 626
 627     return $user;
 628 }
 629
 630 =head2 deactivate_user( $userinfo )
 631
 632 Takes a hashref of C<username>.
 633
 634 Sets the users C<active> flag to false (0), and sets all traditions
 635 assigned to them to non-public, updates the storage and returns the
 636 deactivated user.
 637
 638 Returns undef if user not found.
 639
 640 =cut
 641
 642 sub deactivate_user {
 643     my ($self, $userinfo) = @_;
 644     my $username = $userinfo->{username};
 645
 646     throw( "Need to specify a username for deactivation" ) unless $username;
 647
 648     my $user = $self->find_user({ username => $username });
 649     throw( "User $username not found" ) unless $user;
 650
 651     $user->active(0);
 652     foreach my $tradition (@{ $user->traditions }) {
 653         ## Not implemented yet
 654         # $tradition->public(0);
 655     }
 656
 657     ## Should we be using Text::Tradition::Directory also?
 658     $self->update(@{ $user->traditions });
 659
 660     $self->update($user);
 661
 662     return $user;
 663 }
 664
 665 =head2 reactivate_user( $userinfo )
 666
 667 Takes a hashref of C<username>.
 668
 669 Returns the user object if already activated. Activates (sets the
 670 active flag to true (1)), updates the storage and returns the user.
 671
 672 Returns undef if the user is not found.
 673
 674 =cut
 675
 676 sub reactivate_user {
 677     my ($self, $userinfo) = @_;
 678     my $username = $userinfo->{username};
 679
 680     throw( "Need to specify a username for reactivation" ) unless $username;
 681
 682     my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
 683     throw( "User $username not found" ) unless $user;
 684
 685     return $user if $user->active;
 686
 687     $user->active(1);
 688     $self->update($user);
 689
 690     return $user;
 691 }
 692
 693 =head2 delete_user( $userinfo )
 694
 695 CAUTION: Deletes actual data!
 696
 697 Takes a hashref of C<username>.
 698
 699 Returns undef if the user doesn't exist.
 700
 701 Removes the user from the store and returns 1.
 702
 703 =cut
 704
 705 sub delete_user {
 706     my ($self, $userinfo) = @_;
 707     my $username = $userinfo->{username};
 708
 709     throw( "Need to specify a username for deletion" ) unless $username;
 710
 711     my $user = $self->find_user({ username => $username });
 712     throw( "User $username not found" ) unless $user;
 713
 714     ## Should we be using Text::Tradition::Directory for this bit?
 715     $self->delete( @{ $user->traditions });
 716
 717     ## Poof, gone.
 718     $self->delete($user);
 719
 720     return 1;
 721 }
 722
 723 =head2 validate_password( $password )
 724
 725 Takes a password string. Returns true if it is longer than
 726 L</MIN_PASS_LEN>, false otherwise.
 727
 728 Used internally by L</add_user>.
 729
 730 =cut
 731
 732 sub validate_password {
 733     my ($self, $password) = @_;
 734
 735     return if !$password;
 736     return if length($password) < $self->MIN_PASS_LEN;
 737
 738     return 1;
 739 }
 740
 741 =head2 user_traditionlist( $user )
 742
 743 Returns a tradition list (see specification above) but containing only
 744 those traditions visible to the specified user.  If $user is the string
 745 'public', returns only publicly-viewable traditions.
 746
 747 =cut
 748
 749 sub user_traditionlist {
 750     my ($self, $user) = @_;
 751
 752     my @tlist;
 753     if(ref $user && $user->is_admin) {
 754         ## Admin sees all
 755         return $self->traditionlist();
 756     } elsif(ref $user) {
 757         ## We have a user object already, so just fetch its traditions and use tose
 758         foreach my $t (@{ $user->traditions }) {
 759             push( @tlist, { 'id' => $self->object_to_id( $t ),
 760                             'name' => $t->name } );
 761         }
 762         return @tlist;
 763     } elsif($user ne 'public') {
 764         die "Passed neither a user object nor 'public' to user_traditionlist";
 765     }
 766
 767     ## Search for all traditions which allow public viewing
 768         my @list = grep { $_->{public} } $self->traditionlist();
 769         return @list;
 770 }
 771
 772 1;
 773
 774 =head1 LICENSE
 775
 776 This package is free software and is provided "as is" without express
 777 or implied warranty.  You can redistribute it and/or modify it under
 778 the same terms as Perl itself.
 779
 780 =head1 AUTHORS
 781
 782 Tara L Andrews E<lt>aurum@cpan.orgE<gt> (initial release)
 783
 784 Shadowcat Systems L<http://www.scsys.co.uk/> (user functionality; making it all work)
 785