=end testing
=cut
+use Text::Tradition::TypeMap::Entry;
has +typemap => (
- is => 'rw',
- isa => 'KiokuDB::TypeMap',
- default => sub {
- KiokuDB::TypeMap->new(
- isa_entries => {
- "Graph" => KiokuDB::TypeMap::Entry::Naive->new,
- "Graph::AdjacencyMap" => KiokuDB::TypeMap::Entry::Naive->new,
- }
- );
- },
+ is => 'rw',
+ isa => 'KiokuDB::TypeMap',
+ default => sub {
+ KiokuDB::TypeMap->new(
+ isa_entries => {
+ "Text::Tradition" =>
+ KiokuDB::TypeMap::Entry::Naive->new(),
+ "Graph" => Text::Tradition::TypeMap::Entry->new(),
+ "Graph::AdjacencyMap" => Text::Tradition::TypeMap::Entry->new(),
+ }
+ );
+ },
);
# Push some columns into the extra_args
return $class->$orig( $args );
};
-before [ qw/ store update insert delete / ] => sub {
+## 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?
# TODO Garbage collection doesn't work. Suck it up and live with the
# inflated DB.
-# after delete => sub {
-# my $self = shift;
-# my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
-# $self->directory->backend->delete( $gc->garbage->members );
-# };
+after delete => sub {
+ my $self = shift;
+ my $gc = KiokuDB::GC::Naive->new( backend => $self->directory->backend );
+ $self->directory->backend->delete( $gc->garbage->members );
+};
sub save {
my $self = shift;
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};
sub add_user {
my ($self, $userinfo) = @_;
- my $username = $userinfo->{url} || $userinfo->{username};
+
+ my $username = $userinfo->{username};
my $password = $userinfo->{password};
+ my $role = $userinfo->{role} || 'user';
- return unless ($username =~ /^https?:/
- || ($username && $self->validate_password($password))) ;
+ throw( "No username given" ) unless $username;
+ throw( "Invalid password - must be at least " . $self->MIN_PASS_LEN
+ . " characters long" )
+ unless ( $self->validate_password($password) || $username =~ /^https?:/ );
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);
}
sub create_user {
- my $self = shift;
- return $self->add_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>, optionally C<openid_identifier>.
+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.
sub find_user {
my ($self, $userinfo) = @_;
- ## url or display?
- # 'display' => 'castaway.myopenid.com',
- # 'url' => 'http://castaway.myopenid.com/',
- my $username = $userinfo->{url} || $userinfo->{username};
- return $self->lookup(Text::Tradition::User->id_for_user($username));
-
+ ## 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
my ($self, $userinfo) = @_;
my $username = $userinfo->{username};
my $password = $userinfo->{password};
+ my $role = $userinfo->{role};
- return unless $username && $self->validate_password($password);
+ throw( "Missing username or bad password" )
+ unless $username && $self->validate_password($password);
my $user = $self->find_user({ username => $username });
- return unless $user;
+ throw( "Could not find user $username" ) unless $user;
- $user->password(crypt_password($password));
+ if($password) {
+ $user->password(crypt_password($password));
+ }
+ if($role) {
+ $user->role($role);
+ }
$self->update($user);
my ($self, $userinfo) = @_;
my $username = $userinfo->{username};
- return if !$username;
+ throw( "Need to specify a username for deactivation" ) unless $username;
my $user = $self->find_user({ username => $username });
- return if !$user;
+ throw( "User $username not found" ) unless $user;
$user->active(0);
foreach my $tradition (@{ $user->traditions }) {
my ($self, $userinfo) = @_;
my $username = $userinfo->{username};
- return if !$username;
+ throw( "Need to specify a username for reactivation" ) unless $username;
- my $user = $self->find_user({ username => $username });
- return if !$user;
+ my $user = $self->lookup(Text::Tradition::User->id_for_user($username));
+ throw( "User $username not found" ) unless $user;
return $user if $user->active;
my ($self, $userinfo) = @_;
my $username = $userinfo->{username};
- return if !$username;
+ throw( "Need to specify a username for deletion" ) unless $username;
my $user = $self->find_user({ username => $username });
- return if !$user;
+ throw( "User $username not found" ) unless $user;
## Should we be using Text::Tradition::Directory for this bit?
$self->delete( @{ $user->traditions });
projects / scpubgit/stemmatology.git / blobdiff