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 Graph;
use JSON qw/ encode_json decode_json /;
use LWP::UserAgent;
+use Text::LevenshteinXS qw/ distance /;
use Text::Tradition;
use Text::Tradition::Stemma;
use TryCatch;
if( $rdg ) {
$rdghash->{'text'} = $rdg->text .
( $rdg->rank == $rank ? '' : ' [' . $rdg->rank . ']' );
+ $rdghash->{'is_ungrammatical'} = $rdg->grammar_invalid;
+ $rdghash->{'is_nonsense'} = $rdg->is_nonsense;
}
# Remove lacunose witnesses from this reading's list now that the
# analysis is done
my $subgraph = {};
my $acstr = $c->ac_label;
my @acwits;
- $DB::single = 1 if $variant_row->{id} == 87;
# Note which witnesses positively belong to which group
foreach my $rdghash ( @{$variant_row->{'readings'}} ) {
my $rid = $rdghash->{'readingid'};
# Resolve the relationship of the parent to the reading, and
# save it in our hash.
my $pobj = $c->reading( $p );
- my $relation;
my $prep = $pobj ? $pobj->id . ' (' . $pobj->text . ')' : $p;
+ my $phash = { 'label' => $prep };
if( $pobj ) {
my $rel = $c->get_relationship( $p, $rdghash->{readingid} );
if( $rel ) {
- $relation = { type => $rel->type };
+ $phash->{relation} = { type => $rel->type };
if( $rel->has_annotation ) {
- $relation->{'annotation'} = $rel->annotation;
+ $phash->{relation}->{'annotation'} = $rel->annotation;
+ }
+ } elsif( $rdghash->{readingid} eq '(omitted)' ) {
+ $phash->{relation} = { type => 'deletion' };
+ } elsif( $rdghash->{text} ) {
+ # Check for sheer word similarity.
+ my $rtext = $rdghash->{text};
+ my $ptext = $pobj->text;
+ my $min = length( $rtext ) > length( $ptext )
+ ? length( $ptext ) : length( $rtext );
+ my $distance = distance( $rtext, $ptext );
+ if( $distance < $min ) {
+ $phash->{relation} = { type => 'wordsimilar' };
}
}
- }
- $rdgparents->{$p} = { 'label' => $prep, 'relation' => $relation };
+ # Get the attributes of the parent object while we are here
+ $phash->{'text'} = $pobj->text if $pobj;
+ $phash->{'is_nonsense'} = $pobj->is_nonsense;
+ $phash->{'is_ungrammatical'} = $pobj->grammar_invalid;
+ } elsif( $p eq '(omitted)' ) {
+ $phash->{relation} = { type => 'addition' };
+ }
+ # Save it
+ $rdgparents->{$p} = $phash;
}
$rdghash->{'reading_parents'} = $rdgparents;
use Moose::Util::TypeConstraints;
enum 'RelationshipType' => qw( spelling orthographic grammatical lexical
- collated repetition transposition );
+ collated repetition transposition punctuation );
enum 'RelationshipScope' => qw( local document global );
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
next unless $rdg->has_lexemes;
next if grep { !$_->is_disambiguated } $rdg->lexemes;
next if is_sameword( $c, $r, $rdg );
+ # Do the grammatical link if applicable
my $gram;
if( join( ' ', map { $_->form->lemma } $rdg->lexemes ) eq $rlem
&& $rlem !~ /\<unknown\>/ ) {
$c->add_relationship( $r, $rdg, { 'type' => 'grammatical' } );
$gram = 1;
}
+
+ # Do a punctuation link (instead of a lexical link) if applicable
+ my $punct;
+ if( $rdg->text =~ /^[[:punct:]]$/ && $r->text =~ /^[[:punct:]]$/ ) {
+ say sprintf( "Linking %s (%s) and %s (%s) with punctuation rel",
+ $r, $r->text, $rdg, $rdg->text );
+ $c->add_relationship( $r, $rdg, { 'type' => 'punctuation' } );
+ $punct = 1;
+ }
+
+ # Do the lexical link if applicable
my @rdgpos = map { $_->form->morphstr } $rdg->lexemes;
next unless @rpos == @rdgpos;
my $lex = 1;
$lex = 0;
}
}
- if( $lex ) {
+ if( $lex && !$punct ) {
if( $gram ) {
warn sprintf( "Grammatical link already made for %s (%s) / %s (%s)",
$r, $r->text, $rdg, $rdg->text );
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' => '0.22';
+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 => '/users/success',
+ action_after_register => '/users/success',
+ register_email_from => '"Stemmaweb" <stemmaweb@byzantini.st>',
+ 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 => '6LfR19MSAAAAACy2meHvLfZGRn3PM2rRYIAfh665',
+ priv_key => '6LfR19MSAAAAAMlQb8BdyecWNRE1bAL2YSgz2sah',
+ },
);
# 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';
}
# Get the analysis options
my( $use_type1, $ignore_sort ) = ( 0, 'none' );
if( $c->req->method eq 'POST' ) {
- $use_type1 = $c->req->param( 'show_type1' ) eq 'on' ? 1 : 0;
+ $use_type1 = $c->req->param( 'show_type1' ) ? 1 : 0;
$ignore_sort = $c->req->param( 'ignore_variant' );
}
$c->stash->{'show_type1'} = $use_type1;
my %analysis_options;
$analysis_options{'exclude_type1'} = !$use_type1;
if( $ignore_sort eq 'spelling' ) {
- $analysis_options{'collapse'} = [ qw/ spelling orthographic / ];
+ $analysis_options{'merge_types'} = [ qw/ spelling orthographic / ];
} elsif( $ignore_sort eq 'orthographic' ) {
- $analysis_options{'collapse'} = 'orthographic';
+ $analysis_options{'merge_types'} = 'orthographic';
}
my $t = run_analysis( $tradition, %analysis_options );
--- /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 adaptation 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();
+ }
+ }
+};
+
+=head2 success
+
+A stub page returned on login / registration success.
+
+=cut
+
+sub success :Local :Args(0) {
+ my ( $self, $c ) = @_;
+
+ $c->load_status_msgs;
+ $c->stash->{template} = 'auth/success.tt';
+}
+
+=head2 post_logout
+
+Return to the index page, not to the login page.
+
+=cut
+
+sub post_logout {
+ my( $self, $c ) = @_;
+ $c->response->redirect( $c->uri_for_action( '/index' ) );
+ $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
+#topbanner {
+ width: 100%;
+ height: 50px;
+ margin-top: 20px;
+}
+.error {
+ color: #d24848;
+}
-#options {
- position: relative;
- border: 1px #c6dcf1 solid;
- margin-left: 20px;
- margin-bottom: 20px;
- padding: 10px;
- width: 500px;
-}
-.optionformelement {
- float: left;
- padding-left: 15px;
-}
-#options_button {
- position: absolute;
- bottom: 20px;
- right: 20px;
+#topbanner {
+ width: 100%;
+ height: 100px;
+ margin-top: 20px;
+}
+#bannerinfo {
+ float: right;
+ margin-right: 12%;
+ margin-top: 15px;
}
#variants_table {
clear: both;
background-position: bottom left;
}
+#topbanner {
+ width: 100%;
+ height: 100px;
+ margin-top: 20px;
+}
+#bannerinfo {
+ float: right;
+ margin-right: 12%;
+ margin-top: 15px;
+}
+.navlink {
+ color: #488dd2;
+ text-decoration: underline;
+}
+
+
/* Index page components */
// Save the original unextended SVG for when we need it.
$(document).ready(function () {
original_svg = $('#stemma_graph > svg').clone();
+
+ $('#aboutlink').popupWindow({
+ height:500,
+ width:800,
+ top:50,
+ left:50,
+ scrollbars:1
+ });
+ $('#options').dialog({
+ autoOpen: false,
+ height: 200,
+ width: 300,
+ modal: true,
+ buttons: {
+ Cancel: function() {
+ $(this).dialog( "close" );
+ },
+ Reanalyze: function() {
+ $('#use_variants_form').submit();
+ },
+ }
+ });
+
});
--- /dev/null
+[% WRAPPER header.tt
+ pagetitle = "Stemmaweb - Sign in"
+ applicationstyle = c.uri_for('/css/auth.css')
+%]
+ <script type="text/javascript">
+$(document).ready(function() {
+ // call out to load the directory div
+ $('#login_actions').accordion();
+ $('.login_button').button();
+ $('#submit').button();
+
+ var status = '[% status_msg %]';
+ if( status == 'Logged in!' ) {
+ setInterval( function ( e ) {
+ window.opener.location.reload(true);
+ window.close();
+ e.preventDefault();
+ }, 2000 );
+ }
+});
+ </script>
+[% END %]
+ <div id="topbanner">
+ <h1>Stemmaweb - Sign in</h1>
+ </div>
+
+<div id="login_status">
+[% 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 %]
+</div>
+[% UNLESS status_msg == 'Logged in!' %]
+<div id="login_actions">
+ <h3><a href="#">Sign in with Google</a></h3>
+ <div>
+ <p>If you have a Google account, you may use it to sign into Stemmaweb.</p>
+ <form method="post" action="[% c.uri_for_action('/users/login') | 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" class="login_button" id="#login_google" value="Sign in with Google"></input>
+ </form>
+ </div>
+
+ <h3><a href="#">Sign in with OpenID</a></h3>
+ <div>
+ <p>If you have an account with an <a href="http://openid.net/get-an-openid/" target="_blank">OpenID provider</a> (e.g. WordPress, Blogger, Flickr, Yahoo), you may use it to sign into Stemmaweb.
+ <form method="post" action="[% c.uri_for_action('/users/login') | html %]" autocomplete="off">
+ <input type="hidden" name="realm" value="openid"/>
+ <input type="text" name="openid_identifier"/>
+ <input type="submit" class="login_button" id="#login_openid" value="Sign in with OpenID"/>
+ </form>
+ </div>
+
+[% UNLESS c.req.param('realm') == 'openid' %]
+ <h3><a href="#">Sign in with Stemmaweb</a></h3>
+ <div>
+ <p>If you do not have Google or another OpenID account, you may <a href="[% c.uri_for_action('/users/register') | html %]">register</a> for a user account here with its own password. Once you are registered, you can use this form to sign in.</p>
+ <form id="login_local_form" method="post" action="[% c.uri_for_action('/users/login') | html %]" autocomplete="off">
+ <input type="hidden" name="realm" value="default"/>
+ [% userlabel = form.field('username').label('Email address') %]
+ [% form.field('username').render %]
+ [% form.field('password').render %]
+
+ [% rememberlabel = form.field('remember').label('Remember me') %]
+ [% form.field('remember').render %]
+
+ [% submitbutton = form.field('submit').value('Sign in with Stemmaweb') %]
+ [% form.field('submit').render %]
+ </form>
+ </div>
+[% END %]
+</div>
+[% END %]
+[% PROCESS footer.tt %]
\ No newline at end of file
--- /dev/null
+[% PROCESS header.tt
+ pagetitle = "Stemmaweb - Register"
+ applicationstyle = c.uri_for('/css/auth.css')
+%]
+[% 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') | html %]" autocomplete="off">
+
+ [% userlabel = form.field('username').label('Email address') %]
+ [% form.field('username').render %]
+ [% 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>
+[% PROCESS footer.tt %]
\ No newline at end of file
--- /dev/null
+[% WRAPPER header.tt
+ pagetitle = "Stemmaweb - Logged in"
+ applicationstyle = c.uri_for('/css/auth.css')
+%]
+ <script type="text/javascript">
+$(document).ready(function() {
+ var status = '[% status_msg %]';
+ var error = '[% error_msg %]';
+ if( status && !error ) {
+ setInterval( function ( e ) {
+ window.opener.location.reload(true);
+ window.close();
+ e.preventDefault();
+ }, 2000 );
+ }
+});
+ </script>
+[% END %]
+ <div id="topbanner">
+ <h1>Stemmaweb - Signed in</h1>
+ </div>
+
+<div id="login_status">
+[% IF status_msg %]
+ <p>[% status_msg | html %]</p>
+ <p>Please wait...</p>
+[% END %]
+</div>
+[% PROCESS footer.tt %]
\ 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 %] <a class="navlink" href="[% c.uri_for( '/logout' ) %]">Sign out</a> | [% ELSE %]<a class="navlink" onclick="window.open('[% c.uri_for( '/login' ) %]', 'loginwindow', 'height=385,width=445')">Login</a> | <a class="navlink" onclick="window.open('[% c.uri_for( '/register' ) %]', 'regwindow', 'height=385,width=445')">Register</a> | [% END %]<a class="navlink" href="[% c.uri_for( 'about.html' ) %]">About<a> </span>
</div>
<div id="directory_container">
<h2>Text directory</h2>
--- /dev/null
+Thank you for registering with Stemmaweb!
+
var graphdot = '[% graphdot %]';
</script>
[% END -%]
- <h1>Stexaminer</h1>
- <h2>[% text_title %]</h2>
- <div id="options">
- <h3>Analysis options:</h3>
- <form id="use_variants_form" name="use_variants_form" class="clearfix" method="POST">
- <div class="optionformelement">
- <input type="radio" name="ignore_variant" value="none" [% 'checked="true"' IF ignore_variant == 'none' %]>Analyze all variation</input><br/>
- <input type="radio" name="ignore_variant" value="orthographic" [% 'checked="true"' IF ignore_variant == 'orthographic' %]>Ignore orthographic variation</input><br/>
- <input type="radio" name="ignore_variant" value="spelling" [% 'checked="true"' IF ignore_variant == 'spelling' %]>Ignore orthographic and spelling variation</input>
- </div>
- <div class="optionformelement">
- <input type="checkbox" name="show_type1" [% 'checked="true"' IF show_type1 %]>Include type-1 variation</input>
- </div>
- <div id="options_button" class="button optionformelement" onclick="$('#use_variants_form').submit()">
- <span>Re-analyze</span>
- </div>
- </form>
+ <div id="topbanner">
+ <div id="bannerinfo">
+ <a href="help" title="Stexaminer help" class="navlink" id="aboutlink">Help / About</a>
+ </div>
+ <h1>Stexaminer</h1>
+ <h2>[% text_title %]</h2>
+ <p><span class="navlink" onClick="$('#options').dialog('open')">Analysis options</span></p>
</div>
<div id="variants_table">
<table>
<ul class="reading_parent_list"></ul>
</div>
</div>
+
+ <div id="options" title="Analysis options...">
+ <form id="use_variants_form" name="use_variants_form">
+ <fieldset>
+ <input type="radio" name="ignore_variant" value="none" [% 'checked="true"' IF ignore_variant == 'none' %]>Analyze all variation</input><br/>
+ <input type="radio" name="ignore_variant" value="orthographic" [% 'checked="true"' IF ignore_variant == 'orthographic' %]>Ignore orthographic variation</input><br/>
+ <input type="radio" name="ignore_variant" value="spelling" [% 'checked="true"' IF ignore_variant == 'spelling' %]>Ignore orthographic and spelling variation</input>
+ </fieldset>
+ <fieldset>
+ <input type="checkbox" name="show_type1" [% 'checked="true"' IF show_type1 %]>Include type-1 variation</input>
+ </fieldset>
+ </form>
+ </div>
+
[% PROCESS footer.tt %]
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