From: Tara L Andrews Date: Thu, 12 Jul 2012 23:12:37 +0000 (+0200) Subject: Merge branch 'master' of github.com:tla/stemmatology X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2Fstemmatology.git;a=commitdiff_plain;h=378de72495d704d9de710a0b9c6cfec146de7886;hp=339786dd0b0c493786af4df1ec3bc7ef2bf497e2 Merge branch 'master' of github.com:tla/stemmatology --- diff --git a/lib/Text/Tradition.pm b/lib/Text/Tradition.pm index c2c49c1..ce64e1d 100644 --- a/lib/Text/Tradition.pm +++ b/lib/Text/Tradition.pm @@ -6,6 +6,7 @@ use Moose; use Text::Tradition::Collation; use Text::Tradition::Stemma; use Text::Tradition::Witness; +use Text::Tradition::User; use vars qw( $VERSION ); $VERSION = "0.5"; @@ -61,6 +62,21 @@ has '_initialized' => ( 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; diff --git a/lib/Text/Tradition/Analysis.pm b/lib/Text/Tradition/Analysis.pm index 1a3e7b1..c51f3fd 100644 --- a/lib/Text/Tradition/Analysis.pm +++ b/lib/Text/Tradition/Analysis.pm @@ -8,6 +8,7 @@ use Exporter 'import'; 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; @@ -213,6 +214,8 @@ sub run_analysis { 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 @@ -667,7 +670,6 @@ sub analyze_location { 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'}; @@ -743,18 +745,37 @@ sub analyze_location { # 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; diff --git a/lib/Text/Tradition/Collation/Relationship.pm b/lib/Text/Tradition/Collation/Relationship.pm index f9035fc..227bb7b 100644 --- a/lib/Text/Tradition/Collation/Relationship.pm +++ b/lib/Text/Tradition/Collation/Relationship.pm @@ -4,7 +4,7 @@ use Moose; use Moose::Util::TypeConstraints; enum 'RelationshipType' => qw( spelling orthographic grammatical lexical - collated repetition transposition ); + collated repetition transposition punctuation ); enum 'RelationshipScope' => qw( local document global ); diff --git a/lib/Text/Tradition/Directory.pm b/lib/Text/Tradition/Directory.pm index 9472b46..dfbbeee 100644 --- a/lib/Text/Tradition/Directory.pm +++ b/lib/Text/Tradition/Directory.pm @@ -10,6 +10,10 @@ use KiokuDB::TypeMap; 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 @@ -31,11 +35,37 @@ Text::Tradition::Directory - a KiokuDB interface for storing and retrieving trad 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 @@ -194,12 +224,14 @@ around BUILDARGS => sub { 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; @@ -245,11 +277,43 @@ sub tradition { 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}; @@ -281,6 +345,258 @@ sub throw { ); } + +# 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, C. + +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, and possibly openIDish results from +L. + +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 and C (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. + +Sets the users C 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. + +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. + +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, false otherwise. + +Used internally by L. + +=cut + +sub validate_password { + my ($self, $password) = @_; + + return if !$password; + return if length($password) < $self->MIN_PASS_LEN; + + return 1; +} + 1; =head1 LICENSE diff --git a/lib/Text/Tradition/User.pm b/lib/Text/Tradition/User.pm new file mode 100644 index 0000000..868c25b --- /dev/null +++ b/lib/Text/Tradition/User.pm @@ -0,0 +1,114 @@ +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 Ls 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. + +=head3 active + +Active flag, defaults to true (1). Will be set to false (0) by +L. + +=head3 traditions + +Returns an ArrayRef of L objects belonging to this user. + +=head2 METHODS + +=head3 check_password + +Inherited from KiokuX::User, verifies a given password string against +the stored encrypted version. + diff --git a/lib/Text/Tradition/UserStore.pm b/lib/Text/Tradition/UserStore.pm new file mode 100644 index 0000000..4927611 --- /dev/null +++ b/lib/Text/Tradition/UserStore.pm @@ -0,0 +1,268 @@ +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 for managing the storage and creation of +L 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, C. + +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, optionally C. + +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 and C (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. + +Sets the users C 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. + +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. + +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, false otherwise. + +Used internally by L. + +=cut + +sub validate_password { + my ($self, $password) = @_; + + return if !$password; + return if length($password) < $self->MIN_PASS_LEN; + + return 1; +} + +1; diff --git a/script/admin_users.pl b/script/admin_users.pl new file mode 100644 index 0000000..737573d --- /dev/null +++ b/script/admin_users.pl @@ -0,0 +1,242 @@ +#!/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 to change if necessary. + +=back diff --git a/script/poslink.pl b/script/poslink.pl index 0f4be38..4b99b9f 100755 --- a/script/poslink.pl +++ b/script/poslink.pl @@ -111,6 +111,7 @@ foreach my $tinfo ( $dir->traditionlist() ) { 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 !~ /\/ ) { @@ -119,6 +120,17 @@ foreach my $tinfo ( $dir->traditionlist() ) { $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; @@ -134,7 +146,7 @@ foreach my $tinfo ( $dir->traditionlist() ) { $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 ); diff --git a/stemmaweb/Makefile.PL b/stemmaweb/Makefile.PL index a31e6ed..40572d0 100644 --- a/stemmaweb/Makefile.PL +++ b/stemmaweb/Makefile.PL @@ -18,6 +18,16 @@ requires 'Catalyst::Model::KiokuDB'; 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'; diff --git a/stemmaweb/lib/stemmaweb.pm b/stemmaweb/lib/stemmaweb.pm index 94121c1..ba6ea4a 100644 --- a/stemmaweb/lib/stemmaweb.pm +++ b/stemmaweb/lib/stemmaweb.pm @@ -4,6 +4,10 @@ use 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, @@ -20,6 +24,12 @@ use Catalyst qw/ ConfigLoader Static::Simple Unicode::Encoding + Authentication + Session + Session::Store::File + Session::State::Cookie + StatusMessage + StackTrace /; extends 'Catalyst'; @@ -48,6 +58,65 @@ __PACKAGE__->config( 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" ', + 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 diff --git a/stemmaweb/lib/stemmaweb/Controller/Root.pm b/stemmaweb/lib/stemmaweb/Controller/Root.pm index 3b6ba88..90f9e8a 100644 --- a/stemmaweb/lib/stemmaweb/Controller/Root.pm +++ b/stemmaweb/lib/stemmaweb/Controller/Root.pm @@ -41,15 +41,15 @@ sub index :Path :Args(0) { 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'; } diff --git a/stemmaweb/lib/stemmaweb/Controller/Stexaminer.pm b/stemmaweb/lib/stemmaweb/Controller/Stexaminer.pm index e7eee1b..4b8bff6 100644 --- a/stemmaweb/lib/stemmaweb/Controller/Stexaminer.pm +++ b/stemmaweb/lib/stemmaweb/Controller/Stexaminer.pm @@ -43,7 +43,7 @@ sub index :Path :Args(1) { # 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; @@ -52,9 +52,9 @@ sub index :Path :Args(1) { 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 ); diff --git a/stemmaweb/lib/stemmaweb/Controller/Users.pm b/stemmaweb/lib/stemmaweb/Controller/Users.pm new file mode 100644 index 0000000..32f629f --- /dev/null +++ b/stemmaweb/lib/stemmaweb/Controller/Users.pm @@ -0,0 +1,127 @@ +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, see +there for most of the functionality. Any localised parts are described +below. + +This controller uses L to +create and check a reCaptcha form shown on the C 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 value is passed in when +the openid providing webserver links the user back to the stemmaweb +site. This adaptation to the C action sets the realm we are +authenticating against to be C 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 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; diff --git a/stemmaweb/lib/stemmaweb/View/Email/Template.pm b/stemmaweb/lib/stemmaweb/View/Email/Template.pm new file mode 100644 index 0000000..91f3784 --- /dev/null +++ b/stemmaweb/lib/stemmaweb/View/Email/Template.pm @@ -0,0 +1,34 @@ +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 + +=head1 LICENSE + +This library is free software, you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + +1; diff --git a/stemmaweb/root/css/auth.css b/stemmaweb/root/css/auth.css new file mode 100644 index 0000000..0717b5f --- /dev/null +++ b/stemmaweb/root/css/auth.css @@ -0,0 +1,8 @@ +#topbanner { + width: 100%; + height: 50px; + margin-top: 20px; +} +.error { + color: #d24848; +} diff --git a/stemmaweb/root/css/stexaminer.css b/stemmaweb/root/css/stexaminer.css index 5bf6401..703dfc1 100644 --- a/stemmaweb/root/css/stexaminer.css +++ b/stemmaweb/root/css/stexaminer.css @@ -1,19 +1,12 @@ -#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; diff --git a/stemmaweb/root/css/style.css b/stemmaweb/root/css/style.css index a3047f9..4aaa2b9 100644 --- a/stemmaweb/root/css/style.css +++ b/stemmaweb/root/css/style.css @@ -58,6 +58,22 @@ div.button:hover span { 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 */ diff --git a/stemmaweb/root/js/stexaminer.js b/stemmaweb/root/js/stexaminer.js index 2a9e10e..7469615 100644 --- a/stemmaweb/root/js/stexaminer.js +++ b/stemmaweb/root/js/stexaminer.js @@ -95,4 +95,27 @@ function show_stats( rs ) { // 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(); + }, + } + }); + }); diff --git a/stemmaweb/root/src/auth/login.tt b/stemmaweb/root/src/auth/login.tt new file mode 100644 index 0000000..61575b1 --- /dev/null +++ b/stemmaweb/root/src/auth/login.tt @@ -0,0 +1,87 @@ +[% WRAPPER header.tt + pagetitle = "Stemmaweb - Sign in" + applicationstyle = c.uri_for('/css/auth.css') +%] + +[% END %] +
+

Stemmaweb - Sign in

+
+ +
+[% IF status_msg %] +

[% status_msg | html %]

+[% END %] +[% IF error_msg %] +

[% error_msg | html %]

+[% END %] + +[% IF form.has_errors %] +

Some fields had errors:

+ +
    + [% FOREACH msg IN form.errors %] +
  • [% msg | html %]
    • + [% END %] +
+[% END %] +
+[% UNLESS status_msg == 'Logged in!' %] +
+

Sign in with Google

+
+

If you have a Google account, you may use it to sign into Stemmaweb.

+
+ + + +
+
+ +

Sign in with OpenID

+
+

If you have an account with an OpenID provider (e.g. WordPress, Blogger, Flickr, Yahoo), you may use it to sign into Stemmaweb. +

+ + + +
+
+ +[% UNLESS c.req.param('realm') == 'openid' %] +

Sign in with Stemmaweb

+
+

If you do not have Google or another OpenID account, you may register for a user account here with its own password. Once you are registered, you can use this form to sign in.

+
+ + [% 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 %] +
+
+[% END %] +
+[% END %] +[% PROCESS footer.tt %] \ No newline at end of file diff --git a/stemmaweb/root/src/auth/register.tt b/stemmaweb/root/src/auth/register.tt new file mode 100644 index 0000000..97384be --- /dev/null +++ b/stemmaweb/root/src/auth/register.tt @@ -0,0 +1,37 @@ +[% PROCESS header.tt + pagetitle = "Stemmaweb - Register" + applicationstyle = c.uri_for('/css/auth.css') +%] +[% IF status_msg %] +

[% status_msg | html %]

+[% END %] +[% IF error_msg %] +

[% error_msg | html %]

+[% END %] + +[% IF form.has_errors %] +

Some fields had errors:

+ +
    + [% FOREACH msg IN form.errors %] +
  • [% msg | html %]
    • + [% END %] +
+[% END %] + +
+ + [% userlabel = form.field('username').label('Email address') %] + [% form.field('username').render %] + [% form.field('password').render %] + [% form.field('confirm_password').render %] + + [% IF recaptcha_error %] +

[% recaptcha_error | html %]

+ [% END %] + [% recaptcha %] + + [% form.field('submit').render %] + +
+[% PROCESS footer.tt %] \ No newline at end of file diff --git a/stemmaweb/root/src/auth/success.tt b/stemmaweb/root/src/auth/success.tt new file mode 100644 index 0000000..39189cf --- /dev/null +++ b/stemmaweb/root/src/auth/success.tt @@ -0,0 +1,29 @@ +[% WRAPPER header.tt + pagetitle = "Stemmaweb - Logged in" + applicationstyle = c.uri_for('/css/auth.css') +%] + +[% END %] +
+

Stemmaweb - Signed in

+
+ +
+[% IF status_msg %] +

[% status_msg | html %]

+

Please wait...

+[% END %] +
+[% PROCESS footer.tt %] \ No newline at end of file diff --git a/stemmaweb/root/src/index.tt b/stemmaweb/root/src/index.tt index 61fe470..4131aeb 100644 --- a/stemmaweb/root/src/index.tt +++ b/stemmaweb/root/src/index.tt @@ -14,7 +14,7 @@ $(document).ready(function() {

Stemmaweb - a collection of tools for analysis of collated texts

- About | Help + [% IF c.user_exists %]Hello! [% c.user.get_object.email %] Sign out | [% ELSE %]Login | Register | [% END %]About

Text directory

diff --git a/stemmaweb/root/src/register-plain.tt b/stemmaweb/root/src/register-plain.tt new file mode 100644 index 0000000..517cc8c --- /dev/null +++ b/stemmaweb/root/src/register-plain.tt @@ -0,0 +1,2 @@ +Thank you for registering with Stemmaweb! + diff --git a/stemmaweb/root/src/stexaminer.tt b/stemmaweb/root/src/stexaminer.tt index de72766..63505f7 100644 --- a/stemmaweb/root/src/stexaminer.tt +++ b/stemmaweb/root/src/stexaminer.tt @@ -8,23 +8,13 @@ var readingstats = [% reading_statistics %]; var graphdot = '[% graphdot %]'; [% END -%] -

Stexaminer

-

[% text_title %]

-
-

Analysis options:

-
-
- Analyze all variation
- Ignore orthographic variation
- Ignore orthographic and spelling variation -
-
- Include type-1 variation -
-
- Re-analyze -
-
+
+ +

Stexaminer

+

[% text_title %]

+

Analysis options

@@ -68,6 +58,20 @@ var graphdot = '[% graphdot %]';
    + +
    +
    +
    + Analyze all variation
    + Ignore orthographic variation
    + Ignore orthographic and spelling variation +
    +
    + Include type-1 variation +
    + +
    + [% PROCESS footer.tt %] diff --git a/stemmaweb/stemmaweb.conf b/stemmaweb/stemmaweb.conf index a64ce1e..a0169dc 100644 --- a/stemmaweb/stemmaweb.conf +++ b/stemmaweb/stemmaweb.conf @@ -3,4 +3,7 @@ name = stemmaweb dsn dbi:SQLite:dbname=db/traditions.db - \ No newline at end of file + + + dsn dbi:SQLite:dbname=db/traditions.db + diff --git a/stemmaweb/t/controller_Users.t b/stemmaweb/t/controller_Users.t new file mode 100644 index 0000000..7fe5bfd --- /dev/null +++ b/stemmaweb/t/controller_Users.t @@ -0,0 +1,10 @@ +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(); diff --git a/stemmaweb/t/view_Email-Template.t b/stemmaweb/t/view_Email-Template.t new file mode 100644 index 0000000..acaf00a --- /dev/null +++ b/stemmaweb/t/view_Email-Template.t @@ -0,0 +1,8 @@ +use strict; +use warnings; +use Test::More; + + +BEGIN { use_ok 'stemmaweb::View::Email::Template' } + +done_testing(); diff --git a/t/text_tradition_user.t b/t/text_tradition_user.t new file mode 100644 index 0000000..bf36587 --- /dev/null +++ b/t/text_tradition_user.t @@ -0,0 +1,261 @@ +#!/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'); +}