[Bast-commits] r3328 - in trunk/DBIx-Class-Schema-RestrictByUser: . lib/DBIx/Class/Schema lib/DBIx/Class/Schema/RestrictByUser/RestrictComp t t/lib t/lib/RestrictByUserTest t/lib/RestrictByUserTest/Schema t/var

groditi at dev.catalyst.perl.org groditi at dev.catalyst.perl.org
Sat May 19 03:59:20 GMT 2007


Author: groditi
Date: 2007-05-19 03:59:19 +0100 (Sat, 19 May 2007)
New Revision: 3328

Added:
   trunk/DBIx-Class-Schema-RestrictByUser/Makefile.PL
   trunk/DBIx-Class-Schema-RestrictByUser/README
   trunk/DBIx-Class-Schema-RestrictByUser/t/
   trunk/DBIx-Class-Schema-RestrictByUser/t/02pod.t
   trunk/DBIx-Class-Schema-RestrictByUser/t/03podcoverage.t.disabled
   trunk/DBIx-Class-Schema-RestrictByUser/t/04basic.t
   trunk/DBIx-Class-Schema-RestrictByUser/t/05restrict.t
   trunk/DBIx-Class-Schema-RestrictByUser/t/lib/
   trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest.pm
   trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/
   trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema.pm
   trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema/
   trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema/Notes.pm
   trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema/Users.pm
   trunk/DBIx-Class-Schema-RestrictByUser/t/var/
   trunk/DBIx-Class-Schema-RestrictByUser/t/var/RestrictByUserTest.db
Modified:
   trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser.pm
   trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Schema.pm
   trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Source.pm
Log:
Docs, Tests, the start of a real dist. hopefully going to CPAN soon

Added: trunk/DBIx-Class-Schema-RestrictByUser/Makefile.PL
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/Makefile.PL	                        (rev 0)
+++ trunk/DBIx-Class-Schema-RestrictByUser/Makefile.PL	2007-05-19 02:59:19 UTC (rev 3328)
@@ -0,0 +1,15 @@
+#! /usr/bin/perl -w
+
+# Load the Module::Install bundled in ./inc/
+use inc::Module::Install;
+
+# Define metadata
+name 'DBIx-Class-Schema-RestrictByUser';
+abstract 'Restrict ResultSets by user';
+all_from 'lib/DBIx/Class/Schema/RestrictByUser.pm';
+
+# Specific dependencies
+requires 'DBIx::Class' => 0.07000; ##just a safe number, no rhyme or reason
+
+auto_install;
+WriteAll;

Added: trunk/DBIx-Class-Schema-RestrictByUser/README
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/README	                        (rev 0)
+++ trunk/DBIx-Class-Schema-RestrictByUser/README	2007-05-19 02:59:19 UTC (rev 3328)
@@ -0,0 +1,38 @@
+DBIx-Class-Schema-RestrictByUser
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+    perl Makefile.PL
+    make
+    make test
+    make install
+
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the perldoc command.
+
+    perldoc DBIx::Class::Schema::RestrictByUser
+
+You can also look for information at:
+
+    Search CPAN
+        http://search.cpan.org/dist/DBIx-Class-Schema-RestrictByUser
+
+    CPAN Request Tracker:
+        http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-Schema-RestrictByUser
+
+    AnnoCPAN, annotated CPAN documentation:
+        http://annocpan.org/dist/DBIx-Class-Schema-RestrictByUser
+
+    CPAN Ratings:
+        http://cpanratings.perl.org/d/DBIx-Class-Schema-RestrictByUser
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2007 Matt S Trout &  Guillermo Roditi
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.

Modified: trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Schema.pm
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Schema.pm	2007-05-18 22:21:40 UTC (rev 3327)
+++ trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Schema.pm	2007-05-19 02:59:19 UTC (rev 3328)
@@ -4,6 +4,33 @@
 use warnings;
 use base qw/DBIx::Class::AccessorGroup/;
 
+=head1 DESCRIPTION
+
+For general usage please see L<DBIx::Class::Schema::RestrictByUser>, the information
+provided here is not meant for general use and is subject to change. In the interest
+of transparency the functionality presented is documented, but all methods should be
+considered private and, as such, subject to incompatible changes and removal.
+
+=head1 ADDITIONAL ACCESSORS 
+
+=head2 user
+
+Store the user object used to restict resultsets
+
+=head2 restricted_prefix
+
+Store the prefix, if any, to use when looking for the appropriate resstrict
+methods in the user object
+
+=cut
+
 __PACKAGE__->mk_group_accessors('simple' => 'user');
+__PACKAGE__->mk_group_accessors('simple' => 'restricted_prefix');
 
 1;
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::RestrictByUser>,
+
+=cut

Modified: trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Source.pm
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Source.pm	2007-05-18 22:21:40 UTC (rev 3327)
+++ trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Source.pm	2007-05-19 02:59:19 UTC (rev 3328)
@@ -3,18 +3,43 @@
 use strict;
 use warnings;
 
+=head1 DESCRIPTION
+
+For general usage please see L<DBIx::Class::Schema::RestrictByUser>, the information
+provided here is not meant for general use and is subject to change. In the interest
+of transparency the functionality presented is documented, but all methods should be
+considered private and, as such, subject to incompatible changes and removal.
+
+=head1 PRIVATE METHODS
+
+=head2 resultset
+
+Intercept call to C<resultset> and return restricted resultset
+
+=cut
+  
 sub resultset {
   my $self = shift;
   my $rs = $self->next::method(@_);
   if (my $user = $self->schema->user) {
     my $s = $self->source_name;
     $s =~ s/::/_/g;
+    my $pre = $self->schema->restricted_prefix;
     my $meth = "restrict_${s}_resultset";
-    if ($user->can($meth)) {
-      $rs = $user->$meth($rs);
-    }
+    
+    if($pre){
+      my $meth_pre = "restrict_${pre}_${s}_resultset";
+      return $user->$meth_pre($rs) if $user->can($meth_pre);
+    }    
+    $rs = $user->$meth($rs) if $user->can($meth);
   }
   return $rs;
 }
 
 1;
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::RestrictByUser>,
+
+=cut

Modified: trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser.pm
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser.pm	2007-05-18 22:21:40 UTC (rev 3327)
+++ trunk/DBIx-Class-Schema-RestrictByUser/lib/DBIx/Class/Schema/RestrictByUser.pm	2007-05-19 02:59:19 UTC (rev 3328)
@@ -6,14 +6,85 @@
 # (c) Matt S Trout 2006, all rights reserved
 # this is free software under the same license as perl itself
 
+use vars qw($VERSION);
+$VERSION = '0.0001_01';
+
+=head1 NAME
+
+DBIx::Class::Schema::RestrictByUser - Automatically restrict resultsets by user
+
+=head1 SYNOPSYS
+
+In your L<DBIx::Class::Schema> class:
+
+   __PACKAGE__->load_components(qw/Schema::RestrictByUser/);
+
+In the L<DBIx::Class> table class for your users:
+
+   #let's pretend a user has_many notes, which are in ResultSet 'Notes'
+  sub restrict_Notes_resultset {
+    my $self = shift; #the User object
+    my $unrestricted_rs = shift;
+    
+    #restrict the notes viewable to only those that belong to this user
+    #this will, in effect make the following 2 equivalent
+    # $user->notes $schema->resultset('Notes')
+    return $self->related_resultset('notes');
+  }
+
+   #it could also be written like this
+  sub restrict_Notes_resultset {
+    my $self = shift; #the User object
+    my $unrestricted_rs = shift;
+    return $unrestricted_rs->search_rs( { user_id => $self->id } );
+  }
+
+Wherever you connect to your database
+
+  my $schema = MyApp::Schema->connect(...);
+  my $user = $schema->resultset('User')->find( { id => $user_id } );
+  $resticted_schema = $schema->restrict_by_user( $user, $optional_prefix);
+
+=cut
+
+=head1 DESCRIPTION
+
+This L<DBIx::Class::Schema> component can be used to restrict all resultsets through
+an appropriately-named method in a user's result_class. This can be done to 
+automatically prevent data from being accessed by a user, effectively enforcing 
+security by limiting any access to the data store.
+
+=head1 PUBLIC METHODS
+
+=head2 restrict_by_user $user_obj, $optional_prefix
+
+Will restrict resultsets according to the methods available in $user_obj and 
+return a restricted copy of itself. ResultSets will be restricted if methods 
+in the form  of C<restrict_${ResultSet_Name}_resultset> are found in $user_obj. 
+If the optional prefix is included it will attempt to use 
+C<restrict_${prefix}_${ResultSet_Name}_resultset>, if that does not exist, it 
+will try again without the prefix, and if that's not available the resultset 
+will not be restricted.
+
+=cut
+
 sub restrict_by_user {
-  my ($self, $user) = @_;
+  my ($self, $user, $prefix) = @_;
   my $copy = $self->clone;
   $copy->make_restricted;
   $copy->user($user);
+  $copy->restricted_prefix($prefix) if $prefix;
   return $copy;
 }
 
+=head1 PRIVATE METHODS
+
+=head2 make_restricted
+
+Restrict the Schema class and ResultSources associated with this Schema
+
+=cut
+
 sub make_restricted {
   my ($self) = @_;
   my $class = ref($self);
@@ -27,16 +98,34 @@
   }
 }
 
+=head2 _get_restricted_schema_class $target_schema
+
+Return the class name for the restricted schema class;
+
+=cut
+
 sub _get_restricted_schema_class {
   my ($self, $target) = @_;
   return $self->_get_restricted_class(Schema => $target);
 }
 
+=head2 _get_restricted_source_class $target_source
+
+Return the class name for the restricted ResultSource class;
+
+=cut
+
 sub _get_restricted_source_class {
   my ($self, $target) = @_;
   return $self->_get_restricted_class(Source => $target);
 }
 
+=head2 _get_restrictedclass $type, $target
+
+Return an appropriate class name for a restricted class of type $type.
+
+=cut
+
 sub _get_restricted_class {
   my ($self, $type, $target) = @_;
   my $r_class = join('::', $target, '__RestrictedByUser');
@@ -50,3 +139,23 @@
 }
 
 1;
+
+__END__;
+
+=head1 SEE ALSO 
+
+L<DBIx::Class>, L<DBIx::Class::Schema::RestrictByUser::RestrictComp::Schema>,
+L<DBIx::Class::Schema::RestrictByUser::RestrictComp::Source>,
+
+=head1 AUTHORS
+
+Matt S Trout (mst) <mst at shadowcatsystems.co.uk>
+
+With contributions from
+Guillermo Roditi (groditi) <groditi at cpan.org>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut

Added: trunk/DBIx-Class-Schema-RestrictByUser/t/02pod.t
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/t/02pod.t	                        (rev 0)
+++ trunk/DBIx-Class-Schema-RestrictByUser/t/02pod.t	2007-05-19 02:59:19 UTC (rev 3328)
@@ -0,0 +1,6 @@
+use Test::More;
+
+eval "use Test::Pod 1.14";
+plan skip_all => 'Test::Pod 1.14 required' if $@;
+
+all_pod_files_ok();

Added: trunk/DBIx-Class-Schema-RestrictByUser/t/03podcoverage.t.disabled
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/t/03podcoverage.t.disabled	                        (rev 0)
+++ trunk/DBIx-Class-Schema-RestrictByUser/t/03podcoverage.t.disabled	2007-05-19 02:59:19 UTC (rev 3328)
@@ -0,0 +1,7 @@
+use Test::More;
+
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => 'Test::Pod::Coverage 1.04 required' if $@;
+plan skip_all => 'set TEST_POD to enable this test' unless $ENV{TEST_POD};
+
+all_pod_coverage_ok();

Added: trunk/DBIx-Class-Schema-RestrictByUser/t/04basic.t
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/t/04basic.t	                        (rev 0)
+++ trunk/DBIx-Class-Schema-RestrictByUser/t/04basic.t	2007-05-19 02:59:19 UTC (rev 3328)
@@ -0,0 +1,14 @@
+use strict;
+use warnings;
+use Test::More;
+
+BEGIN {
+    eval "use DBD::SQLite";
+    plan $@
+        ? ( skip_all => 'needs DBD::SQLite for testing' )
+        : ( tests => 1 );       
+}
+
+use lib qw(t/lib);
+
+use_ok('DBIx::Class::Schema::RestrictByUser');

Added: trunk/DBIx-Class-Schema-RestrictByUser/t/05restrict.t
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/t/05restrict.t	                        (rev 0)
+++ trunk/DBIx-Class-Schema-RestrictByUser/t/05restrict.t	2007-05-19 02:59:19 UTC (rev 3328)
@@ -0,0 +1,47 @@
+use strict;
+use warnings;
+use Test::More;
+
+use Scalar::Util;
+
+plan (tests => 17);
+
+use lib qw(t/lib);
+
+use RestrictByUserTest;
+my $schema = RestrictByUserTest->init_schema;
+ok($schema, "Connected successfully");
+
+my $user1 = $schema->resultset('Users')->create({name => 'user1'});
+my $user2 = $schema->resultset('Users')->create({name => 'user2'});
+ok(ref $user1 && ref $user2, "Successfully created mock users");
+
+ok($user1->notes->create({name => 'note 1-1'}), "Successfully created 1-1 note");
+ok($user1->notes->create({name => 'note 1-2'}), "Successfully created 1-2 note");
+
+ok($user2->notes->create({name => 'note 2-1'}), "Successfully created 2-1 note");
+ok($user2->notes->create({name => 'note 2-2'}), "Successfully created 2-2 note");
+ok($user2->notes->create({name => 'note 2-3'}), "Successfully created 2-3 note");
+ok($user2->notes->create({name => 'note 2-4'}), "Successfully created 2-4 note");
+
+my $u1_schema = $schema->restrict_by_user($user1);
+my $u2_schema = $schema->restrict_by_user($user2, "MY");
+my $u3_schema = $schema->restrict_by_user($user2, "BUNK");
+
+is($u1_schema->user->id, $user1->id, "Correct restriction for user 1");
+is($u2_schema->user->id, $user2->id, "Correct restriction for user 2");
+is($u2_schema->restricted_prefix, "MY", "Correct prefix for user 2");
+
+ok(Scalar::Util::refaddr($u1_schema) ne Scalar::Util::refaddr($u2_schema), 
+   "Successful clones");
+
+is($schema->resultset('Notes')->count, 6, 'Correct un resticted count');
+is($u1_schema->resultset('Notes')->count, 2, 'Correct resticted count');
+is($u2_schema->resultset('Notes')->count, 4, 'Correct resticted count using prefix');
+is($u2_schema->resultset('Notes')->count, 4, 
+   'Correct resticted count using prefix and fallback');
+
+is($u2_schema->resultset('Users')->count, 2, 'Unrestricted resultsets work');
+
+
+1;

Added: trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema/Notes.pm
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema/Notes.pm	                        (rev 0)
+++ trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema/Notes.pm	2007-05-19 02:59:19 UTC (rev 3328)
@@ -0,0 +1,26 @@
+package # hide from PAUSE 
+    RestrictByUserTest::Schema::Notes;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components('Core');
+__PACKAGE__->table('notes_test');
+__PACKAGE__->add_columns(
+  'id' => {
+    data_type => 'int',
+    is_nullable	=> 0,
+    is_auto_increment => 1,
+  },
+  'user_id' => {
+    data_type => 'int',
+  },
+  'name' => {
+    data_type => 'varchar',
+    size      => 100,
+  }
+);
+
+__PACKAGE__->set_primary_key('id');
+__PACKAGE__->belongs_to("user", "Users", { id => "user_id" });
+
+1;

Added: trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema/Users.pm
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema/Users.pm	                        (rev 0)
+++ trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema/Users.pm	2007-05-19 02:59:19 UTC (rev 3328)
@@ -0,0 +1,37 @@
+package # hide from PAUSE 
+   RestrictByUserTest::Schema::Users;
+
+use base 'DBIx::Class';
+
+__PACKAGE__->load_components('Core');
+__PACKAGE__->table('test_users');
+__PACKAGE__->add_columns(
+  'id' => {
+    data_type => 'int',
+    is_nullable	=> 0,
+    is_auto_increment => 1,
+  },
+  'name' => {
+    data_type => 'varchar',
+    size      => 40,
+  }
+);
+
+__PACKAGE__->set_primary_key('id');
+__PACKAGE__->has_many("notes", "Notes", { "foreign.user_id" => "self.id" });
+
+sub restrict_Notes_resultset {
+  my $self = shift; #the User object
+  my $unrestricted_rs = shift;
+  
+  return $self->related_resultset('notes');
+}
+
+sub restrict_MY_Notes_resultset {
+  my $self = shift; #the User object
+  my $unrestricted_rs = shift;
+  
+  return $unrestricted_rs->search_rs( { user_id => $self->id } );
+}
+
+1;

Added: trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema.pm
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema.pm	                        (rev 0)
+++ trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest/Schema.pm	2007-05-19 02:59:19 UTC (rev 3328)
@@ -0,0 +1,9 @@
+package # hide from PAUSE 
+  RestrictByUserTest::Schema;
+
+use base qw/DBIx::Class::Schema/;
+
+__PACKAGE__->load_classes(qw/ Users Notes /);
+__PACKAGE__->load_components('Schema::RestrictByUser');
+
+1;

Added: trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest.pm
===================================================================
--- trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest.pm	                        (rev 0)
+++ trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest.pm	2007-05-19 02:59:19 UTC (rev 3328)
@@ -0,0 +1,21 @@
+package # hide from PAUSE 
+    RestrictByUserTest;
+
+use strict;
+use warnings;
+use RestrictByUserTest::Schema;
+
+sub init_schema {
+    my $self = shift;
+    my $db_file = "t/var/RestrictByUserTest.db";
+
+    unlink($db_file) if -e $db_file;
+    unlink($db_file . "-journal") if -e $db_file . "-journal";
+    mkdir("t/var") unless -d "t/var";
+
+    my $schema = RestrictByUserTest::Schema->connect( "dbi:SQLite:${db_file}");
+    $schema->deploy();
+    return $schema;
+}
+
+1;


Property changes on: trunk/DBIx-Class-Schema-RestrictByUser/t/lib/RestrictByUserTest.pm
___________________________________________________________________
Name: svn:executable
   + *

Added: trunk/DBIx-Class-Schema-RestrictByUser/t/var/RestrictByUserTest.db
===================================================================
(Binary files differ)


Property changes on: trunk/DBIx-Class-Schema-RestrictByUser/t/var/RestrictByUserTest.db
___________________________________________________________________
Name: svn:mime-type
   + application/octet-stream




More information about the Bast-commits mailing list