X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FText%2FTradition%2FDirectory.pm;h=0d7a2f9f5de4e2974b6bd57a74ceba747ba710cc;hb=b77f6c1bee7890af1189201ff40eb8005e3e671f;hp=b697f7c46b62bd12c7099e58686bd7d39c500b0b;hpb=770f7a2ba4284bedc3d23e91d0a7923f5f37d721;p=scpubgit%2Fstemmatology.git

diff --git a/lib/Text/Tradition/Directory.pm b/lib/Text/Tradition/Directory.pm
index b697f7c..0d7a2f9 100644
--- a/lib/Text/Tradition/Directory.pm
+++ b/lib/Text/Tradition/Directory.pm
@@ -181,18 +181,21 @@ is( ref( $nt ), 'Text::Tradition', "Made new tradition" );
 =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
@@ -221,12 +224,12 @@ around BUILDARGS => sub {
 	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?
@@ -245,11 +248,11 @@ before [ qw/ store update insert delete / ] => sub {
 
 # 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;
@@ -274,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};
@@ -336,15 +371,21 @@ Create a new user object, store in the KiokuDB backend, and return it.
 
 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);
@@ -353,13 +394,41 @@ sub add_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.
 
@@ -367,13 +436,21 @@ 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
@@ -391,13 +468,20 @@ sub 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);
 
@@ -420,10 +504,10 @@ sub deactivate_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 }) {
@@ -454,10 +538,10 @@ sub reactivate_user {
     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;
 
@@ -483,10 +567,10 @@ sub delete_user {
     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 });