From: Guillermo Roditi <groditi@cpan.org>
Date: Sat, 19 May 2007 16:46:38 +0000 (+0000)
Subject: rename restrict by user
X-Git-Tag: 0.0001~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=772c89c170f979890e5f8d7e7522d50e8dc0323e;p=dbsrgits%2FDBIx-Class-Schema-RestrictWithObject.git

rename restrict by user
---

772c89c170f979890e5f8d7e7522d50e8dc0323e
diff --git a/Changes b/Changes
new file mode 100644
index 0000000..555ac37
--- /dev/null
+++ b/Changes
@@ -0,0 +1,2 @@
+0.00001_01 NODATEYET
+        -initial release
diff --git a/MANIFEST b/MANIFEST
new file mode 100644
index 0000000..ad00065
--- /dev/null
+++ b/MANIFEST
@@ -0,0 +1,27 @@
+Changes
+inc/Module/AutoInstall.pm
+inc/Module/Install.pm
+inc/Module/Install/AutoInstall.pm
+inc/Module/Install/Base.pm
+inc/Module/Install/Can.pm
+inc/Module/Install/Fetch.pm
+inc/Module/Install/Include.pm
+inc/Module/Install/Makefile.pm
+inc/Module/Install/Metadata.pm
+inc/Module/Install/Win32.pm
+inc/Module/Install/WriteAll.pm
+lib/DBIx/Class/Schema/RestrictByUser.pm
+lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Schema.pm
+lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Source.pm
+Makefile.PL
+MANIFEST			This list of files
+META.yml
+README
+t/02pod.t
+t/03podcoverage.t.disabled
+t/04basic.t
+t/05restrict.t
+t/lib/RestrictByUserTest.pm
+t/lib/RestrictByUserTest/Schema.pm
+t/lib/RestrictByUserTest/Schema/Notes.pm
+t/lib/RestrictByUserTest/Schema/Users.pm
diff --git a/Makefile.PL b/Makefile.PL
new file mode 100644
index 0000000..293a59d
--- /dev/null
+++ b/Makefile.PL
@@ -0,0 +1,23 @@
+#! /usr/bin/perl -w
+
+# Load the Module::Install bundled in ./inc/
+use inc::Module::Install;
+
+# Define metadata
+name 'DBIx-Class-Schema-RestrictWithObject';
+abstract 'Restrict ResultSets';
+all_from 'lib/DBIx/Class/Schema/RestrictWithObject.pm';
+
+# Specific dependencies
+requires 'DBIx::Class' => 0.07000; ##just a safe number, no rhyme or reason
+
+build_requires 'Test::More' => 0;
+
+#ANYONE WANT TO GIVE ME VERSION NUMBERS??? PLEASE??
+build_requires 'SQL::Translator' => 0;
+build_requires 'Test::More' => 0;
+build_requires 'Scalar::Util' => 0;
+build_requires 'DBD::SQLite'  => 0;
+
+auto_install;
+WriteAll;
diff --git a/README b/README
new file mode 100644
index 0000000..fefb80c
--- /dev/null
+++ b/README
@@ -0,0 +1,38 @@
+DBIx-Class-Schema-RestrictWithObject
+
+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::RestrictWithObject
+
+You can also look for information at:
+
+    Search CPAN
+        http://search.cpan.org/dist/DBIx-Class-Schema-RestrictWithObject
+
+    CPAN Request Tracker:
+        http://rt.cpan.org/NoAuth/Bugs.html?Dist=DBIx-Class-Schema-RestrictWithObject
+
+    AnnoCPAN, annotated CPAN documentation:
+        http://annocpan.org/dist/DBIx-Class-Schema-RestrictWithObject
+
+    CPAN Ratings:
+        http://cpanratings.perl.org/d/DBIx-Class-Schema-RestrictWithObject
+
+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.
diff --git a/lib/DBIx/Class/Schema/RestrictByUser.pm b/lib/DBIx/Class/Schema/RestrictByUser.pm
new file mode 100644
index 0000000..ed62caa
--- /dev/null
+++ b/lib/DBIx/Class/Schema/RestrictByUser.pm
@@ -0,0 +1,160 @@
+package DBIx::Class::Schema::RestrictByUser;
+
+our $VERSION = '0.0001_01';
+
+use DBIx::Class::Schema::RestrictByUser::RestrictComp::Schema;
+use DBIx::Class::Schema::RestrictByUser::RestrictComp::Source;
+
+# (c) Matt S Trout 2006, all rights reserved
+# this is free software under the same license as perl itself
+
+=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, $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);
+  my $r_class = $self->_get_restricted_schema_class($class);
+  bless($self, $r_class);
+  foreach my $moniker ($self->sources) {
+    my $source = $self->source($moniker);
+    my $class = ref($source);
+    my $r_class = $self->_get_restricted_source_class($class);
+    bless($source, $r_class);
+  }
+}
+
+=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');
+  unless (eval { $r_class->can('can') }) {
+    my $r_comp = join(
+      '::', 'DBIx::Class::Schema::RestrictByUser::RestrictComp', $type
+    );
+    $self->inject_base($r_class, $r_comp, $target);
+  }
+  return $r_class;
+}
+
+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@shadowcatsystems.co.uk>
+
+With contributions from
+Guillermo Roditi (groditi) <groditi@cpan.org>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
diff --git a/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Schema.pm b/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Schema.pm
new file mode 100644
index 0000000..f9eee65
--- /dev/null
+++ b/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Schema.pm
@@ -0,0 +1,36 @@
+package DBIx::Class::Schema::RestrictByUser::RestrictComp::Schema;
+
+use strict;
+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
diff --git a/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Source.pm b/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Source.pm
new file mode 100644
index 0000000..0a8ecd1
--- /dev/null
+++ b/lib/DBIx/Class/Schema/RestrictByUser/RestrictComp/Source.pm
@@ -0,0 +1,45 @@
+package DBIx::Class::Schema::RestrictByUser::RestrictComp::Source;
+
+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($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
diff --git a/t/02pod.t b/t/02pod.t
new file mode 100644
index 0000000..ddc2905
--- /dev/null
+++ b/t/02pod.t
@@ -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();
diff --git a/t/03podcoverage.t.disabled b/t/03podcoverage.t.disabled
new file mode 100644
index 0000000..d91be5e
--- /dev/null
+++ b/t/03podcoverage.t.disabled
@@ -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();
diff --git a/t/04basic.t b/t/04basic.t
new file mode 100644
index 0000000..69f2c88
--- /dev/null
+++ b/t/04basic.t
@@ -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');
diff --git a/t/05restrict.t b/t/05restrict.t
new file mode 100644
index 0000000..3682be0
--- /dev/null
+++ b/t/05restrict.t
@@ -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;
diff --git a/t/lib/RestrictByUserTest.pm b/t/lib/RestrictByUserTest.pm
new file mode 100755
index 0000000..70933ab
--- /dev/null
+++ b/t/lib/RestrictByUserTest.pm
@@ -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;
diff --git a/t/lib/RestrictByUserTest/Schema.pm b/t/lib/RestrictByUserTest/Schema.pm
new file mode 100644
index 0000000..843e466
--- /dev/null
+++ b/t/lib/RestrictByUserTest/Schema.pm
@@ -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;
diff --git a/t/lib/RestrictByUserTest/Schema/Notes.pm b/t/lib/RestrictByUserTest/Schema/Notes.pm
new file mode 100644
index 0000000..3248c48
--- /dev/null
+++ b/t/lib/RestrictByUserTest/Schema/Notes.pm
@@ -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;
diff --git a/t/lib/RestrictByUserTest/Schema/Users.pm b/t/lib/RestrictByUserTest/Schema/Users.pm
new file mode 100644
index 0000000..73b8178
--- /dev/null
+++ b/t/lib/RestrictByUserTest/Schema/Users.pm
@@ -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;
diff --git a/t/var/RestrictByUserTest.db b/t/var/RestrictByUserTest.db
new file mode 100644
index 0000000..bf10322
Binary files /dev/null and b/t/var/RestrictByUserTest.db differ