use Text::Tradition::Collation;
use Text::Tradition::Stemma;
use Text::Tradition::Witness;
+use Text::Tradition::User;
use vars qw( $VERSION );
$VERSION = "0.5";
writer => '_init_done',
);
+has 'user' => (
+ is => 'rw',
+ isa => 'Text::Tradition::User',
+ required => 0,
+ predicate => 'has_user',
+ clearer => 'clear_user',
+ );
+
+has 'public' => (
+ is => 'rw',
+ isa => 'Bool',
+ required => 0,
+ default => sub { 0; },
+ );
+
# Create the witness before trying to add it
around 'add_witness' => sub {
my $orig = shift;
use KiokuDB::TypeMap::Entry::Naive;
use Text::Tradition::Error;
+## users
+use KiokuX::User::Util qw(crypt_password);
+use Text::Tradition::User;
+
extends 'KiokuX::Model';
=head1 NAME
foreach my $id ( $d->traditions ) {
print $d->tradition( $id )->name;
}
+
+ ## Users:
+ my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
+ my $newuser = $userstore->add_user({ username => 'fred',
+ password => 'somepassword' });
+
+ my $fetchuser = $userstore->find_user({ username => 'fred' });
+ if($fetchuser->check_password('somepassword')) {
+ ## login user or .. whatever
+ }
+
+ my $user = $userstore->deactivate_user({ username => 'fred' });
+ if(!$user->active) {
+ ## shouldnt be able to login etc
+ }
=head1 DESCRIPTION
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.
+=head1 ATTRIBUTES
+
+=head2 MIN_PASS_LEN
+
+Constant for the minimum password length when validating passwords,
+defaults to "8".
+
+=cut
+
+has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
+
=head1 METHODS
=head2 new
return $class->$orig( $args );
};
+## These checks don't cover store($id, $obj)
# before [ qw/ store update insert delete / ] => sub {
before [ qw/ delete / ] => sub {
my $self = shift;
my @nontrad;
foreach my $obj ( @_ ) {
- if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition' ) {
+ if( ref( $obj ) && ref( $obj ) ne 'Text::Tradition'
+ && ref ($obj) ne 'Text::Tradition::User' ) {
# Is it an id => Tradition hash?
if( ref( $obj ) eq 'HASH' && keys( %$obj ) == 1 ) {
my( $k ) = keys %$obj;
return $obj;
}
+sub user_traditionlist {
+ my ($self, $user) = @_;
+
+ my @tlist;
+ if(ref $user && $user->is_admin) {
+ ## Admin sees all
+ return $self->traditionlist();
+ } elsif(ref $user) {
+ ## We have a user object already, so just fetch its traditions and use tose
+ foreach my $t (@{ $user->traditions }) {
+ push( @tlist, { 'id' => $self->object_to_id( $t ),
+ 'name' => $t->name } );
+ }
+ return @tlist;
+ } elsif($user ne 'public') {
+ die "Passed neither a user object nor 'public' to user_traditionlist";
+ }
+
+ ## Search for all traditions which allow public viewing
+ ## When they exist!
+## This needs to be more sophisticated, probably needs Search::GIN
+# my $list = $self->search({ public => 1 });
+
+ ## For now, just fetch all
+ ## (could use all_objects or grep down there?)
+ return $self->traditionlist();
+}
+
sub traditionlist {
my $self = shift;
+ my ($user) = @_;
+
+ return $self->user_traditionlist($user) if($user);
+
+ my @tlist;
# If we are using DBI, we can do it the easy way; if not, the hard way.
# Easy way still involves making a separate DBI connection. Ew.
- my @tlist;
if( $self->dsn =~ /^dbi:(\w+):/ ) {
my $dbtype = $1;
my @connection = @{$self->directory->backend->connect_info};
);
}
+
+# has 'directory' => (
+# is => 'rw',
+# isa => 'KiokuX::Model',
+# handles => []
+# );
+
+## TODO: Some of these methods should probably optionally take $user objects
+## instead of hashrefs.
+
+## It also occurs to me that all these methods don't need to be named
+## XX_user, but leaving that way for now incase we merge this code
+## into ::Directory for one-store.
+
+## To die or not to die, on error, this is the question.
+
+=head2 add_user
+
+Takes a hashref of C<username>, C<password>.
+
+Create a new user object, store in the KiokuDB backend, and return it.
+
+=cut
+
+sub add_user {
+ my ($self, $userinfo) = @_;
+
+ my $username = $userinfo->{username};
+ my $password = $userinfo->{password};
+ my $role = $userinfo->{role} || 'user';
+
+ return unless ($username =~ /^https?:/
+ || ($username && $self->validate_password($password))) ;
+
+ my $user = Text::Tradition::User->new(
+ id => $username,
+ password => ($password ? crypt_password($password) : ''),
+ email => ($userinfo->{email} ? $userinfo->{email} : $username),
+ role => $role,
+ );
+
+ $self->store($user->kiokudb_object_id, $user);
+
+ return $user;
+}
+
+sub create_user {
+ my ($self, $userinfo) = @_;
+
+ ## No username means probably an OpenID based user
+ if(!exists $userinfo->{username}) {
+ extract_openid_data($userinfo);
+ }
+
+ return $self->add_user($userinfo);
+}
+
+## Not quite sure where this method should be.. Auth /
+## Credential::OpenID just pass us back the chunk of extension data
+sub extract_openid_data {
+ my ($userinfo) = @_;
+
+ ## Spec says SHOULD use url as identifier
+ $userinfo->{username} = $userinfo->{url};
+
+ ## Use email addy as display if available
+ if(exists $userinfo->{extensions} &&
+ exists $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'} &&
+ defined $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'}) {
+ ## Somewhat ugly attribute extension reponse, contains
+ ## google-email string which we can use as the id
+
+ $userinfo->{email} = $userinfo->{extensions}{'http://openid.net/srv/ax/1.0'}{'value.email'};
+ }
+
+ return;
+}
+
+=head2 find_user
+
+Takes a hashref of C<username>, and possibly openIDish results from
+L<Net::OpenID::Consumer>.
+
+Fetches the user object for the given username and returns it.
+
+=cut
+
+sub find_user {
+ my ($self, $userinfo) = @_;
+
+ ## No username means probably an OpenID based user
+ if(!exists $userinfo->{username}) {
+ extract_openid_data($userinfo);
+ }
+
+ my $username = $userinfo->{username};
+
+ ## No logins if user is deactivated (use lookup to fetch to re-activate)
+ my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
+ return if(!$user || !$user->active);
+
+ print STDERR "Found user, $username, email is :", $user->email, ":\n";
+
+ return $user;
+}
+
+=head2 modify_user
+
+Takes a hashref of C<username> and C<password> (same as add_user).
+
+Retrieves the user, and updates it with the new information. Username
+changing is not currently supported.
+
+Returns the updated user object, or undef if not found.
+
+=cut
+
+sub modify_user {
+ my ($self, $userinfo) = @_;
+ my $username = $userinfo->{username};
+ my $password = $userinfo->{password};
+ my $role = $userinfo->{role};
+
+ return unless $username;
+ return if($password && !$self->validate_password($password));
+
+ my $user = $self->find_user({ username => $username });
+ return unless $user;
+
+ if($password) {
+ $user->password(crypt_password($password));
+ }
+ if($role) {
+ $user->role($role);
+ }
+
+ $self->update($user);
+
+ return $user;
+}
+
+=head2 deactivate_user
+
+Takes a hashref of C<username>.
+
+Sets the users C<active> flag to false (0), and sets all traditions
+assigned to them to non-public, updates the storage and returns the
+deactivated user.
+
+Returns undef if user not found.
+
+=cut
+
+sub deactivate_user {
+ my ($self, $userinfo) = @_;
+ my $username = $userinfo->{username};
+
+ return if !$username;
+
+ my $user = $self->find_user({ username => $username });
+ return if !$user;
+
+ $user->active(0);
+ foreach my $tradition (@{ $user->traditions }) {
+ ## Not implemented yet
+ # $tradition->public(0);
+ }
+
+ ## Should we be using Text::Tradition::Directory also?
+ $self->update(@{ $user->traditions });
+
+ $self->update($user);
+
+ return $user;
+}
+
+=head2 reactivate_user
+
+Takes a hashref of C<username>.
+
+Returns the user object if already activated. Activates (sets the
+active flag to true (1)), updates the storage and returns the user.
+
+Returns undef if the user is not found.
+
+=cut
+
+sub reactivate_user {
+ my ($self, $userinfo) = @_;
+ my $username = $userinfo->{username};
+
+ return if !$username;
+
+ my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
+ return if !$user;
+
+ return $user if $user->active;
+
+ $user->active(1);
+ $self->update($user);
+
+ return $user;
+}
+
+=head2 delete_user
+
+CAUTION: Deletes actual data!
+
+Takes a hashref of C<username>.
+
+Returns undef if the user doesn't exist.
+
+Removes the user from the store and returns 1.
+
+=cut
+
+sub delete_user {
+ my ($self, $userinfo) = @_;
+ my $username = $userinfo->{username};
+
+ return if !$username;
+
+ my $user = $self->find_user({ username => $username });
+ return if !$user;
+
+ ## Should we be using Text::Tradition::Directory for this bit?
+ $self->delete( @{ $user->traditions });
+
+ ## Poof, gone.
+ $self->delete($user);
+
+ return 1;
+}
+
+=head2 validate_password
+
+Takes a password string. Returns true if it is longer than
+L</MIN_PASS_LEN>, false otherwise.
+
+Used internally by L</add_user>.
+
+=cut
+
+sub validate_password {
+ my ($self, $password) = @_;
+
+ return if !$password;
+ return if length($password) < $self->MIN_PASS_LEN;
+
+ return 1;
+}
+
1;
=head1 LICENSE
--- /dev/null
+package Text::Tradition::User;
+
+use strict;
+use warnings;
+
+use Moose;
+with qw(KiokuX::User);
+
+## 'id' provided by KiokuX::User stores our username (email for local users, openid url for openid/google)
+has 'password' => (is => 'rw', required => 1);
+has 'email' => (is => 'rw', lazy => 1, builder => '_build_email');
+## Change this default active value if you want/need to have an admin confirm a user after they self-create.
+has 'active' => (is => 'rw', default => sub { 1; });
+has 'role' => (is => 'rw', default => sub { 'user' });
+# 'traits' => ['Array'] ?
+# https://metacpan.org/module/Moose::Meta::Attribute::Native::Trait::Array
+has 'traditions' => (is => 'rw',
+ traits => ['Array'],
+ handles => {
+ 'add_tradition' => 'push',
+ },
+ isa => 'ArrayRef[Text::Tradition]',
+ default => sub { [] },
+ required => 0);
+
+after add_tradition => sub {
+ my ($self, $tradition) = @_;
+ $tradition->user($self)
+ unless $tradition->has_user && $tradition->user->id eq $self->id;
+};
+
+sub _build_email {
+ my ($self) = @_;
+
+ ## no email set, so use username/id
+ return $self->id;
+}
+
+sub remove_tradition {
+ my ($self, $tradition) = @_;
+
+ ## FIXME: Is "name" a good unique field to compare traditions on?
+ my @traditions = @{$self->traditions};
+ @traditions = grep { $tradition != $_ } @traditions;
+
+ $tradition->clear_user;
+ $self->traditions(\@traditions);
+}
+
+sub is_admin {
+ my ($self) = @_;
+
+ return $self->role && $self->role eq 'admin';
+}
+
+1;
+
+=head1 NAME
+
+Text::Tradition::User - Users which own traditions, and can login to the web app
+
+=head1 SYNOPSIS
+
+ ## Users are managed by Text::Tradition::UserStore
+
+ my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
+ my $newuser = $userstore->add_user({ username => 'fred',
+ password => 'somepassword' });
+
+ my $fetchuser = $userstore->find_user({ username => 'fred' });
+ if($fetchuser->check_password('somepassword')) {
+ ## login user or .. whatever
+ }
+
+ my $user = $userstore->deactivate_user({ username => 'fred' });
+ if(!$user->active) {
+ ## shouldnt be able to login etc
+ }
+
+ foreach my $t (@{ $user->traditions }) {
+ ## do something with traditions owned by this user.
+ }
+
+=head1 DESCRIPTION
+
+User objects representing owners of L<Text::Tradition>s and authenticated users.
+
+=head2 ATTRIBUTES
+
+=head3 id
+
+Inherited from KiokuX::User, stores the 'username' (login) of the user.
+
+=head3 password
+
+User's password, encrypted on creation (by
+L<KiokuX::User::Util/crypt_password>.
+
+=head3 active
+
+Active flag, defaults to true (1). Will be set to false (0) by
+L<Text::Tradition::UserStore/deactivate_user>.
+
+=head3 traditions
+
+Returns an ArrayRef of L<Text::Tradition> objects belonging to this user.
+
+=head2 METHODS
+
+=head3 check_password
+
+Inherited from KiokuX::User, verifies a given password string against
+the stored encrypted version.
+
--- /dev/null
+package Text::Tradition::UserStore;
+
+use strict;
+use warnings;
+
+use Moose;
+use KiokuX::User::Util qw(crypt_password);
+
+extends 'Text::Tradition::Directory';
+# extends 'KiokuX::Model';
+
+use Text::Tradition::User;
+
+=head1 NAME
+
+Text::Tradition::UserStore - KiokuDB storage management for Users
+
+=head1 SYNOPSIS
+
+ my $userstore = Text::Tradition::UserStore->new(dsn => 'dbi:SQLite:foo.db');
+ my $newuser = $userstore->add_user({ username => 'fred',
+ password => 'somepassword' });
+
+ my $fetchuser = $userstore->find_user({ username => 'fred' });
+ if($fetchuser->check_password('somepassword')) {
+ ## login user or .. whatever
+ }
+
+ my $user = $userstore->deactivate_user({ username => 'fred' });
+ if(!$user->active) {
+ ## shouldnt be able to login etc
+ }
+
+=head1 DESCRIPTION
+
+A L<KiokuX::Model> for managing the storage and creation of
+L<Text::Tradition::User> objects. Subclass or replace this module in
+order to use a different source for stemmaweb users.
+
+=head2 ATTRIBUTES
+
+=head3 dsn
+
+Inherited from KiokuX::Model - dsn for the data store we are using.
+
+=head3 MIN_PASS_LEN
+
+Constant for the minimum password length when validating passwords,
+defaults to "8".
+
+=cut
+
+has MIN_PASS_LEN => ( is => 'ro', isa => 'Num', default => sub { 8 } );
+
+# has 'directory' => (
+# is => 'rw',
+# isa => 'KiokuX::Model',
+# handles => []
+# );
+
+## TODO: Some of these methods should probably optionally take $user objects
+## instead of hashrefs.
+
+## It also occurs to me that all these methods don't need to be named
+## XX_user, but leaving that way for now incase we merge this code
+## into ::Directory for one-store.
+
+## To die or not to die, on error, this is the question.
+
+=head2 METHODS
+
+=head3 add_user
+
+Takes a hashref of C<username>, C<password>.
+
+Create a new user object, store in the KiokuDB backend, and return it.
+
+=cut
+
+sub add_user {
+ my ($self, $userinfo) = @_;
+ my $username = $userinfo->{url} || $userinfo->{username};
+ my $password = $userinfo->{password};
+
+ return unless ($username =~ /^https?:/
+ || ($username && $self->validate_password($password))) ;
+
+ my $user = Text::Tradition::User->new(
+ id => $username,
+ password => ($password ? crypt_password($password) : ''),
+ );
+
+ my $scope = $self->new_scope;
+ $self->store($user->kiokudb_object_id, $user);
+
+ return $user;
+}
+
+sub create_user {
+ my $self = shift;
+ return $self->add_user(@_);
+}
+
+=head3 find_user
+
+Takes a hashref of C<username>, optionally C<openid_identifier>.
+
+Fetches the user object for the given username and returns it.
+
+=cut
+
+sub find_user {
+ my ($self, $userinfo) = @_;
+ ## url or display?
+ # 'display' => 'castaway.myopenid.com',
+ # 'url' => 'http://castaway.myopenid.com/',
+ my $username = $userinfo->{url} || $userinfo->{username};
+
+ my $scope = $self->new_scope;
+ return $self->lookup(Text::Tradition::User->id_for_user($username));
+
+}
+
+=head3 modify_user
+
+Takes a hashref of C<username> and C<password> (same as add_user).
+
+Retrieves the user, and updates it with the new information. Username
+changing is not currently supported.
+
+Returns the updated user object, or undef if not found.
+
+=cut
+
+sub modify_user {
+ my ($self, $userinfo) = @_;
+ my $username = $userinfo->{username};
+ my $password = $userinfo->{password};
+
+ return unless $username && $self->validate_password($password);
+
+ my $user = $self->find_user({ username => $username });
+ return unless $user;
+
+ my $scope = $self->new_scope;
+ $user->password(crypt_password($password));
+
+ $self->update($user);
+
+ return $user;
+}
+
+=head3 deactivate_user
+
+Takes a hashref of C<username>.
+
+Sets the users C<active> flag to false (0), and sets all traditions
+assigned to them to non-public, updates the storage and returns the
+deactivated user.
+
+Returns undef if user not found.
+
+=cut
+
+sub deactivate_user {
+ my ($self, $userinfo) = @_;
+ my $username = $userinfo->{username};
+
+ return if !$username;
+
+ my $user = $self->find_user({ username => $username });
+ return if !$user;
+
+ $user->active(0);
+ foreach my $tradition (@{ $user->traditions }) {
+ ## Not implemented yet
+ # $tradition->public(0);
+ }
+ my $scope = $self->new_scope;
+
+ ## Should we be using Text::Tradition::Directory also?
+ $self->update(@{ $user->traditions });
+
+ $self->update($user);
+
+ return $user;
+}
+
+=head3 reactivate_user
+
+Takes a hashref of C<username>.
+
+Returns the user object if already activated. Activates (sets the
+active flag to true (1)), updates the storage and returns the user.
+
+Returns undef if the user is not found.
+
+=cut
+
+sub reactivate_user {
+ my ($self, $userinfo) = @_;
+ my $username = $userinfo->{username};
+
+ return if !$username;
+
+ my $user = $self->find_user({ username => $username });
+ return if !$user;
+
+ return $user if $user->active;
+
+ $user->active(1);
+ my $scope = $self->new_scope;
+ $self->update($user);
+
+ return $user;
+}
+
+=head3 delete_user
+
+CAUTION: Delets actual data!
+
+Takes a hashref of C<username>.
+
+Returns undef if the user doesn't exist.
+
+Removes the user from the store and returns 1.
+
+=cut
+
+sub delete_user {
+ my ($self, $userinfo) = @_;
+ my $username = $userinfo->{username};
+
+ return if !$username;
+
+ my $user = $self->find_user({ username => $username });
+ return if !$user;
+
+ my $scope = $self->new_scope;
+
+ ## Should we be using Text::Tradition::Directory for this bit?
+ $self->delete( @{ $user->traditions });
+
+ ## Poof, gone.
+ $self->delete($user);
+
+ return 1;
+}
+
+=head3 validate_password
+
+Takes a password string. Returns true if it is longer than
+L</MIN_PASS_LEN>, false otherwise.
+
+Used internally by L</add_user>.
+
+=cut
+
+sub validate_password {
+ my ($self, $password) = @_;
+
+ return if !$password;
+ return if length($password) < $self->MIN_PASS_LEN;
+
+ return 1;
+}
+
+1;
--- /dev/null
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use v5.10.0;
+
+use Getopt::Long;
+## using prompt():
+use ExtUtils::MakeMaker();
+use lib 'lib';
+
+use Text::Tradition::Directory;
+
+my ($dsn, $command) = ('dbi:SQLite:dbname=db/traditions.db', 'add');
+my ($username, $password, $tradition_id, $rolename);
+
+GetOptions(
+ 'c|command:s' => \$command,
+ 'dsn:s' => \$dsn,
+ 'u|username=s' => \$username,
+ 'p|password:s' => \$password,
+ 't|tradition:s' => \$tradition_id,
+ 'r|role:s' => \$rolename,
+ ) or usage();
+
+if(!$command || !($command ~~ [qw/add modify delete deactivate reactivate list/])) {
+ print "No command supplied, chickening out ... \n\n";
+ usage();
+}
+
+if(!$username) {
+ print "No username supplied, confused ... \n\n";
+ usage();
+}
+
+# my $userstore = Text::Tradition::UserStore->new( dsn => $dsn);
+my $userstore = Text::Tradition::Directory->new( dsn => $dsn);
+my $new_scope = $userstore->new_scope;
+
+given ($command) {
+ when ('add') {
+ ## We only add local users here, OpenID etc users will get auto-added
+ ## when they login
+ if(!$password || !$userstore->validate_password($password)) {
+ print "Can't add a new user without a valid password\n\n";
+ usage();
+ break;
+ }
+ ## Set role as passed in rolename, if set (else gets default "user")
+ my $user = $userstore->add_user({ username => $username,
+ password => $password,
+ ( $rolename ? (role => $rolename) : () ),
+ });
+ if(!$user) {
+ print "Failed to add user! (you should see errors above this..)\n";
+ } else {
+ print "OK.\n";
+ }
+ }
+
+ when ('modify') {
+ if(!$tradition_id && !$password && !$rolename) {
+ print "Can't modify a user without a valid password or a tradition\n\n";
+ usage();
+ break;
+ }
+ if( $password && !$userstore->validate_password($password)) {
+ print "Can't modify a user without a valid password\n\n";
+ usage();
+ break;
+ }
+ my @set_password = ( $password ? ( password => $password ) : () );
+ my @set_role = ( $rolename ? ( role => $rolename ) : () );
+
+ my $user = $userstore->modify_user({ username => $username,
+ @set_password,
+ @set_role,
+ });
+ if(!$user) {
+ print "Failed to modify user! (you should see errors above this..)\n";
+ } else {
+ print "Modified User.\n";
+ }
+
+ if($tradition_id) {
+ my $tradition = $userstore->tradition($tradition_id);
+ my $user = $userstore->find_user({ username => $username });
+ if(!$tradition || !$user) {
+ print "Can't find one of '$username' or '$tradition_id' in the database!\n";
+ } else {
+ if(grep { $userstore->object_to_id($_)
+ eq
+ $userstore->object_to_id($tradition)}
+ @{$user->traditions}) {
+ $user->remove_tradition($tradition);
+ } else {
+ $user->add_tradition($tradition);
+ }
+ $userstore->update($tradition);
+ $userstore->update($user);
+ print "Added Tradition.\n";
+ }
+ }
+
+ print "OK\n";
+ }
+
+ when ('list') {
+ my $user = $userstore->find_user({ username => $username });
+ if(!$user) {
+ print "Can't find user '$username'\n";
+ break;
+ }
+ my $traditions = $user->traditions;
+
+ print "User: $username\n";
+ print "Has traditions: \n";
+ foreach my $t (@$traditions) {
+ print " ", $t->name, "\n";
+ }
+ print "OK.\n";
+ }
+
+ when ('deactivate') {
+ my $user = $userstore->deactivate_user({ username => $username});
+ if(!$user) {
+ print "Failed to deactivate user! (you should see errors above this..)\n";
+ } else {
+ print "OK.\n";
+ }
+ }
+
+ when ('reactivate') {
+ my $user = $userstore->reactivate_user({ username => $username});
+ if(!$user) {
+ print "Failed to reactivate user! (you should see errors above this..)\n";
+ } else {
+ print "OK.\n";
+ }
+ }
+
+ when ('delete') {
+ my $yesno = ExtUtils::MakeMaker::prompt("Permanently delete $username? (y/N)", "n");
+ if($yesno !~ /^y$/i) {
+ print "Not deleting $username\n";
+ break;
+ }
+ my $user = $userstore->delete_user({ username => $username});
+ if(!$user) {
+ print "Failed to delete user! (you should see errors above this..)\n";
+ } else {
+ print "OK.\n";
+ }
+ }
+}
+
+sub usage {
+ print "User Admin tool, to add/modify/deactivate/reactivate/delete users\n";
+ print "===========================================\n";
+ print "Usage: $0 -c add -u jimbob -p hispassword\n";
+ print "Usage: $0 -c modify -u jimbob -p hisnewpassword\n";
+ print "Usage: $0 -c modify -u jimbob -t \"Notre besoin\"\n";
+ print "Usage: $0 -c modify -u jimbob -r \"admin\"\n";
+ print "Usage: $0 -c deactivate -u jimbob\n";
+}
+
+=head1 NAME
+
+admin_users.pl - add / modify / etc users
+
+=head1 SYNOPSIS
+
+ admin_user.pl -c add -u jimbob -p "jimspassword"
+
+ admin_user.pl -c add -u jimbob -p "jimspassword" -r "admin"
+
+ admin_user.pl -c modify -u jimbob -p "jimsnewpassword"
+
+ admin_user.pl -c modify -u jimbob -r "admin"
+
+ admin_user.pl -c modify -u jimbob -t "mytradition"
+
+ admin_user.pl -c list -u jimbob
+
+ admin_user.pl -c delete -u jimbob
+
+=head1 OPTIONS
+
+=over
+
+=item -c | --command
+
+The action to take, can be one of: add, modify, deactivate, reactivate, delete, list.
+
+=over
+
+=item add
+
+Create a new user and store it in the Directory
+
+=item modify
+
+Change an existing stored user, with a -p this will change the user's
+password, with a -t will add or remove the named tradition from the
+user.
+
+=item list
+
+List the given user's traditions.
+
+=item deactivate
+
+Deactivate this user.
+
+=item reactivate
+
+Re-activate this user.
+
+=item delete
+
+Delete the user permanently.
+
+=back
+
+=item -u | --username
+
+The username of the new user or user to change.
+
+=item -p | --password
+
+The new password or password to change.
+
+=item -t | --tradition
+
+A Text::Tradition id or name which will be assigned to the user given.
+
+=item -r | --role
+
+A rolename to add or modify, this is a plain text string to check it carefully. Use C<modify> to change if necessary.
+
+=back
requires 'Catalyst::View::Download::Plain';
requires 'Catalyst::View::JSON';
requires 'Catalyst::View::TT';
+requires 'Catalyst::View::Email::Template';
+## Auth:
+requires 'Catalyst::Plugin::Authentication';
+requires 'Catalyst::Plugin::Session';
+requires 'Catalyst::Plugin::Session::Store::File';
+requires 'Catalyst::Plugin::Session::State::Cookie';
+requires 'CatalystX::Controller::Auth';
+requires 'Catalyst::TraitFor::Controller::reCAPTCHA';
+requires 'LWP::Protocol::https';
+##
requires 'Moose';
requires 'TryCatch';
requires 'namespace::autoclean';
use Catalyst::Runtime 5.80;
+use Search::GIN::Extract::Class;
+use Search::GIN::Extract::Attributes;
+use Search::GIN::Extract::Multiplex;
+
# Set flags and add plugins for the application.
#
# Note that ORDERING IS IMPORTANT here as plugins are initialized in order,
ConfigLoader
Static::Simple
Unicode::Encoding
+ Authentication
+ Session
+ Session::Store::File
+ Session::State::Cookie
+ StatusMessage
+ StackTrace
/;
extends 'Catalyst';
stemmaweb->path_to( 'root', 'src' ),
],
},
+ ## kiokudb auth store testing
+ 'Plugin::Authentication' => {
+ default => {
+ credential => {
+ class => 'Password',
+ password_field => 'password',
+ password_type => 'self_check',
+ },
+ store => {
+ class => 'Model::KiokuDB',
+ model_name => 'Directory',
+ },
+ },
+ openid => {
+ credential => {
+ class => 'OpenID',
+ extensions => ['http://openid.net/srv/ax/1.0' =>
+ {
+ ns => 'ax',
+ uri => 'http://openid.net/srv/ax/1.0',
+ mode => 'fetch_request',
+ required => 'email',
+ 'type.email' => 'http://axschema.org/contact/email',
+ # type => {
+ # email => 'http://axschema.org/contact/email'
+ # }
+ }
+ ],
+ },
+ store => {
+ class => 'Model::KiokuDB',
+ model_name => 'Directory',
+ },
+ auto_create_user => 1,
+ },
+ },
+ ## Auth with CatalystX::Controller::Auth
+ 'Controller::Users' => {
+ model => 'User',
+ login_id_field => 'username',
+ login_db_field => 'username',
+ action_after_login => '/index',
+ action_after_register => '/index',
+ register_email_from => '"MyApp" <somebody@example.com>',
+ register_email_subject => 'Registration to stemmaweb',
+ register_email_template_plain => 'register-plain.tt',
+ realm => 'default',
+ login_fields => { openid => [qw/openid_identifier/],
+ default => [qw/username password remember/],
+ },
+ },
+ 'View::Email::Template' => {
+ stash_key => 'email_template',
+ },
+
+ recaptcha => {
+ pub_key => '',
+ priv_key => '',
+ },
);
# Start the application
GET /directory
-Serves a snippet of HTML that lists the available texts. Eventually this will be available texts by user.
+Serves a snippet of HTML that lists the available texts. This returns texts belonging to the logged-in user if any, otherwise it returns all public texts.
=cut
+
sub directory :Local :Args(0) {
my( $self, $c ) = @_;
my $m = $c->model('Directory');
- # TODO not used yet, will load user texts later
- my $user = $c->request->param( 'user' ) || 'ALL';
- my @textlist = $m->traditionlist();
+ my $user = $c->user_exists ? $c->user->get_object : 'public';
+ my @textlist = $m->traditionlist($user);
$c->stash->{texts} = \@textlist;
$c->stash->{template} = 'directory.tt';
}
--- /dev/null
+package stemmaweb::Controller::Users;
+use Moose;
+use namespace::autoclean;
+
+BEGIN {extends 'CatalystX::Controller::Auth'; }
+with 'Catalyst::TraitFor::Controller::reCAPTCHA';
+
+=head1 NAME
+
+stemmaweb::Controller::Users - Catalyst Controller
+
+=head1 DESCRIPTION
+
+The Users controller is based on L<CatalystX::Controller::Auth>, see
+there for most of the functionality. Any localised parts are described
+below.
+
+This controller uses L<Catalyst::TraitFor::Controller::reCAPTCHA> to
+create and check a reCaptcha form shown on the C<register> form to
+help prevent spam signups.
+
+=head1 METHODS
+
+=cut
+
+sub base :Chained('/') :PathPart('') :CaptureArgs(0)
+{
+ my ( $self, $c ) = @_;
+
+ $self->next::method( $c );
+}
+
+=head2 index
+
+The index action is not currently used.
+
+=cut
+
+sub index :Path :Args(0) {
+ my ( $self, $c ) = @_;
+
+ $c->response->body('Matched stemmaweb::Controller::Users in Users.');
+}
+
+=head2 login with openid
+
+Logging in with openid/google requires two passes through the login
+action, on the 2nd pass the C<openid-check> value is passed in when
+the openid providing webserver links the user back to the stemmaweb
+site. This adaption to the C<login> action sets the realm we are
+authenticating against to be C<openid> in this case.
+
+=cut
+
+before login => sub {
+ my($self, $c) = @_;
+ $c->req->param( realm => 'openid')
+ if $c->req->param('openid-check');
+};
+
+=head2 register with recaptcha
+
+This adapts the C<register> action to add the recaptcha HTML to the
+page, and verify the recaptcha info entered is correct when the form
+is submitted. If the recaptcha is not correct, we just redisplay the
+form with an error message.
+
+=cut
+
+before register => sub {
+ my ($self, $c) = @_;
+
+ ## Puts HTML into stash in "recaptcha" key.
+ $c->forward('captcha_get');
+
+ ## When submitting, check recaptcha passes, else re-draw form
+ if($c->req->method eq 'POST') {
+ if(!$c->forward('captcha_check')) {
+
+ ## Need these two lines to detach, so end can draw the correct template again:
+ my $form = $self->form_handler->new( active => [ $self->login_id_field, 'password', 'confirm_password' ] );
+ $c->stash( template => $self->register_template, form => $form );
+
+ $c->detach();
+ }
+ }
+};
+
+=head1 AUTHOR
+
+A clever guy
+
+=head1 LICENSE
+
+This library is free software. You can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+__PACKAGE__->meta->make_immutable;
+
+1;
--- /dev/null
+package stemmaweb::View::Email::Template;
+
+use strict;
+use base 'Catalyst::View::Email::Template';
+
+__PACKAGE__->config(
+ stash_key => 'email',
+ template_prefix => ''
+);
+
+=head1 NAME
+
+stemmaweb::View::Email::Template - Templated Email View for stemmaweb
+
+=head1 DESCRIPTION
+
+View for sending template-generated email from stemmaweb.
+
+=head1 AUTHOR
+
+A clever guy
+
+=head1 SEE ALSO
+
+L<stemmaweb>
+
+=head1 LICENSE
+
+This library is free software, you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+[% IF status_msg %]
+ <p>[% status_msg | html %]</p>
+[% END %]
+[% IF error_msg %]
+ <p class="error">[% error_msg | html %]</p>
+[% END %]
+
+[% IF form.has_errors %]
+ <p class="error">Some fields had errors:</p>
+
+ <ul class="errors">
+ [% FOREACH msg IN form.errors %]
+ <li>[% msg | html %]</li>
+ [% END %]
+ </ul>
+[% END %]
+
+ <form method="post" action="[% c.uri_for_action('/users/login').hostless | html %]" autocomplete="off">
+
+ <input type="hidden" name="realm" value="openid"/>
+ <input type="hidden" name="openid_identifier" value="https://www.google.com/accounts/o8/id"/>
+ <input type="submit" value="Sign in with Google"/>
+
+ </form>
+
+[% UNLESS c.req.param('realm') == 'openid' %]
+ <form method="post" action="[% c.uri_for_action('/users/login').hostless | html %]" autocomplete="off">
+
+ <input type="hidden" name="realm" value="default"/>
+
+ [% form.field('username').render %]
+ [% form.field('password').render %]
+ [% form.field('remember').render %]
+
+ [% form.field('submit').render %]
+
+ </form>
+[% END %]
\ No newline at end of file
--- /dev/null
+[% IF status_msg %]
+ <p>[% status_msg | html %]</p>
+[% END %]
+[% IF error_msg %]
+ <p class="error">[% error_msg | html %]</p>
+[% END %]
+
+[% IF form.has_errors %]
+ <p class="error">Some fields had errors:</p>
+
+ <ul class="errors">
+ [% FOREACH msg IN form.errors %]
+ <li>[% msg | html %]</li>
+ [% END %]
+ </ul>
+[% END %]
+
+ <form method="post" action="[% c.uri_for_action('/users/register').hostless | html %]" autocomplete="off">
+
+ [% form.field('username').render %] (email)
+ [% form.field('password').render %]
+ [% form.field('confirm_password').render %]
+
+ [% IF recaptcha_error %]
+ <p class="error">[% recaptcha_error | html %]</p>
+ [% END %]
+ [% recaptcha %]
+
+ [% form.field('submit').render %]
+
+ </form>
\ No newline at end of file
<div id="topbanner">
<h1>Stemmaweb - a collection of tools for analysis of collated texts</h1>
- <span class="mainnav"><a href="[% c.uri_for( 'about.html' ) %]">About<a> | <a href="[% c.uri_for( 'doc.html' ) %]">Help</a></span>
+ <span class="mainnav">[% IF c.user_exists %]Hello! [% c.user.get_object.email %] [% ELSE %]<a href="[% c.uri_for('/login') %]">Login</a> | <a href="[% c.uri_for('/register') %]">Register</a> | [% END %]<a href="[% c.uri_for( 'about.html' ) %]">About<a> | <a href="[% c.uri_for( 'doc.html' ) %]">Help</a></span>
</div>
<div id="directory_container">
<h2>Text directory</h2>
--- /dev/null
+Thank you for registering with Stemmaweb!
+
name = stemmaweb
<Model Directory>
dsn dbi:SQLite:dbname=db/traditions.db
-</Model>
\ No newline at end of file
+</Model>
+<Model User>
+ dsn dbi:SQLite:dbname=db/traditions.db
+</Model>
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+
+use Catalyst::Test 'stemmaweb';
+use stemmaweb::Controller::Users;
+
+ok( request('/users')->is_success, 'Request should succeed' );
+done_testing();
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+
+
+BEGIN { use_ok 'stemmaweb::View::Email::Template' }
+
+done_testing();
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+use File::Temp;
+
+use_ok('Text::Tradition::Directory');
+
+my $fh = File::Temp->new();
+my $file = $fh->filename;
+$fh->close;
+my $dsn = "dbi:SQLite:dbname=$file";
+
+my $user_store = Text::Tradition::Directory->new('dsn' => $dsn,
+ 'extra_args' => { 'create' => 1 } );
+
+my $scope = $user_store->new_scope;
+
+## passwords
+my $shortpass = 'bloggs';
+ok(!$user_store->validate_password($shortpass), '"bloggs" is too short for a password');
+
+## create user
+my $new_user = $user_store->add_user({ username => 'fred',
+ password => 'bloggspass'});
+isa_ok($new_user, 'Text::Tradition::User');
+is($new_user->active, 1, 'New user created and active');
+is($new_user->display, 'fred', 'Display value set to username');
+ok(!$new_user->is_admin, 'New user is not an admin');
+
+## find user
+my $find_user = $user_store->find_user({ username => 'fred'});
+isa_ok($find_user, 'Text::Tradition::User');
+ok($find_user->check_password('bloggspass'), 'Stored & retrieved with correct password');
+
+## modify user
+my $changed_user = $user_store->modify_user({ username => 'fred',
+ password => 'passbloggs' });
+isa_ok($changed_user, 'Text::Tradition::User');
+my $changed = $user_store->find_user({ username => 'fred'});
+ok($changed->check_password('passbloggs'), 'Modified & retrieved with correct new password');
+
+{
+## deactivate user
+## Sets all traditions to non-public, deactivates
+ my $user = $user_store->add_user({ username => 'testactive',
+ password => 'imanactiveuser' });
+ ok($user->active, 'Deactivate test user starts active');
+
+ my $d_user = $user_store->deactivate_user({ username => 'testactive' });
+ is($d_user->active, 0, 'Deactivated user');
+ is($user_store->find_user({ username => 'testactive' }), undef, 'Deactivated user not returned by find_user');
+
+## TODO - add test where user has traditions to start with
+}
+
+{
+## reactivate user
+## reactivates user, does not mess with their traditions (as we don't know which were public to start with)
+
+ my $user = $user_store->add_user({ username => 'testinactive',
+ password => 'imaninactiveuser' });
+ my $d_user = $user_store->deactivate_user({ username => 'testinactive' });
+ ok(!$d_user->active, 'Deactivate test user starts active');
+
+ my $a_user = $user_store->reactivate_user({ username => 'testinactive' });
+ is($a_user->active, 1, 'Re-activated user');
+ ok($user_store->find_user({ username => 'testinactive' }), 'Re-activated user returned by find_user again');
+}
+
+{
+## delete user (admin only?)
+ my $user = $user_store->add_user({ username => 'testdelete',
+ password => 'imgoingtobedeleted' });
+
+ my $gone = $user_store->delete_user({ username => 'testdelete' });
+
+ my $d_user = $user_store->find_user({ username => 'testdelete' });
+
+ ok($gone && !$d_user, 'Deleted user completely from store');
+}
+
+{
+## add_tradition
+ use Text::Tradition;
+ my $t = Text::Tradition->new(
+ 'name' => 'inline',
+ 'input' => 'Tabular',
+ 'file' => 't/data/simple.txt',
+ );
+
+ my $uuid = $user_store->save($t);
+ my $user = $user_store->add_user({ username => 'testadd',
+ password => 'testingtraditions' });
+ $user->add_tradition($t);
+ $user_store->update($user);
+
+ is( scalar @{$user->traditions}, 1, 'Added one tradition');
+
+ my @tlist = $user_store->traditionlist($user);
+ is($tlist[0]->{name}, $t->name, 'Traditionlist returns same named user->tradition');
+ is($tlist[0]->{id}, $uuid, 'Traditionlist returns actual tradition with same uuid we put in earlier');
+ my $fetched_t = $user_store->tradition($tlist[0]->{id});
+ is($fetched_t->user->id, $user->id, 'Traditionlist returns item belonging to this user');
+
+ ## add a second, not owned by this user, we shouldn't return it from
+ ## traditionslist
+ my $t2 = Text::Tradition->new(
+ 'name' => 'inline',
+ 'input' => 'Tabular',
+ 'file' => 't/data/simple.txt',
+ );
+ $user_store->save($t2);
+ my @tlist2 = $user_store->traditionlist($user);
+ is(scalar @tlist2, 1, 'With 2 stored traditions, we only fetch one');
+ my $fetched_t2 = $user_store->tradition($tlist[0]->{id});
+ is($fetched_t2->user->id, $user->id, 'Traditionlist returns item belonging to this user');
+
+
+}
+
+
+TODO: {
+ local $TODO = 'searching on public attr not implemented yet';
+ ## Fetch public traditions, not user traditions, when not fetching with a user
+ use Text::Tradition;
+ my $t = Text::Tradition->new(
+ 'name' => 'inline',
+ 'input' => 'Tabular',
+ 'file' => 't/data/simple.txt',
+ );
+
+ $user_store->save($t);
+ my $user = $user_store->add_user({ username => 'testpublic',
+ password => 'testingtraditions' });
+ $user->add_tradition($t);
+ $user_store->update($user);
+
+ ## add a second, not owned by this user, we shouldn't return it from
+ ## traditionslist
+ my $t2 = Text::Tradition->new(
+ 'name' => 'inline',
+ 'input' => 'Tabular',
+ 'file' => 't/data/simple.txt',
+ );
+ $t2->public(1);
+ my $uuid = $user_store->save($t2);
+
+ my @tlist = $user_store->traditionlist('public');
+ is(scalar @tlist, 1, 'Got one public tradition');
+ is($tlist[0]->{name}, $t2->name, 'Traditionlist returns same named user->tradition');
+ is($tlist[0]->{id}, $uuid, 'Traditionlist returns actual tradition with same uuid we put in earlier');
+ my $fetched_t = $user_store->tradition($tlist[0]->{id});
+ ok($fetched_t->public, 'Traditionlist returns public item');
+
+}
+
+{
+## remove_tradition
+ use Text::Tradition;
+ my $t = Text::Tradition->new(
+ 'name' => 'inline',
+ 'input' => 'Tabular',
+ 'file' => 't/data/simple.txt',
+ );
+
+ my $uuid = $user_store->save($t);
+ my $user = $user_store->add_user({ username => 'testremove',
+ password => 'testingtraditions' });
+ $user->add_tradition($t);
+ $user_store->update($user);
+
+ $user->remove_tradition($t);
+ $user_store->update($user);
+ my $changed_t = $user_store->tradition($uuid);
+
+ is( scalar @{$user->traditions}, 0, 'Added and removed one tradition');
+ ok(!$changed_t->has_user, 'Removed user from tradition');
+
+ my @tlist = $user_store->traditionlist($user);
+ is(scalar @tlist, 0, 'Traditionlist now empty');
+}
+
+{
+ ## Add admin user
+ my $admin = $user_store->add_user({
+ username => 'adminuser',
+ password => 'adminpassword',
+ role => 'admin' });
+
+ ok($admin->is_admin, 'Got an admin user');
+
+ ## test admins get all traditions
+ use Text::Tradition;
+ my $t = Text::Tradition->new(
+ 'name' => 'inline',
+ 'input' => 'Tabular',
+ 'file' => 't/data/simple.txt',
+ );
+
+ $user_store->save($t);
+
+ my @tlist = $user_store->traditionlist(); ## all traditions
+ my @admin_tlist = $user_store->traditionlist($admin);
+
+ is(scalar @admin_tlist, scalar @tlist, 'Got all traditions for admin user');
+
+}
+
+{
+ ## Add/find simple openid user with OpenIDish parameters:
+
+ my $openid_user = $user_store->create_user({
+ url => 'http://username.myopenid.com',
+ display => 'username.myopenid.com',
+ });
+ ok($openid_user, 'Created user from OpenID params');
+
+ my $get_openid_user = $user_store->find_user({
+ url => 'http://username.myopenid.com',
+ display => 'username.myopenid.com',
+ });
+
+ ok($openid_user == $get_openid_user, 'Found OpenID user again');
+ is($get_openid_user->id, 'http://username.myopenid.com', 'Set id to unique url from openid');
+ is($get_openid_user->display, 'username.myopenid.com', 'Kept original display value');
+}
+
+{
+ ## Add/find openid user with email attribute:
+ my $openid_user = $user_store->create_user({
+ url => 'http://blahblah.com/foo/bar/baz/lotsofjunk',
+ display => 'http://blahblah.com/foo/bar/baz/lotsofjunk',
+ extensions => {
+ 'http://openid.net/srv/ax/1.0' => {
+ 'value.email' => 'fredbloggs@blahblah.com',
+ 'type.email' => 'http://axschema.org/contact/email',
+ 'mode' => 'fetch_response',
+ },
+ },
+ });
+ ok($openid_user, 'Created user from OpenID params');
+
+ my $get_openid_user = $user_store->find_user({
+ url => 'http://blahblah.com/foo/bar/baz/lotsofjunk',
+ display => 'http://blahblah.com/foo/bar/baz/lotsofjunk',
+ extensions => {
+ 'http://openid.net/srv/ax/1.0' => {
+ 'value.email' => 'fredbloggs@blahblah.com',
+ 'type.email' => 'http://axschema.org/contact/email',
+ 'mode' => 'fetch_response',
+ },
+ },
+ });
+
+ ok($openid_user == $get_openid_user, 'Found OpenID user again');
+ is($get_openid_user->id, 'http://blahblah.com/foo/bar/baz/lotsofjunk', 'Set id to unique url from openid');
+ is($get_openid_user->display, 'fredbloggs@blahblah.com', 'Set display value to email from extension');
+}
projects / scpubgit/stemmatology.git / commitdiff