lib/DBIx/Class/Schema/RestrictByUser.pm

   1 package DBIx::Class::Schema::RestrictByUser;
   2
   3 our $VERSION = '0.0001_01';
   4
   5 use DBIx::Class::Schema::RestrictByUser::RestrictComp::Schema;
   6 use DBIx::Class::Schema::RestrictByUser::RestrictComp::Source;
   7
   8 # (c) Matt S Trout 2006, all rights reserved
   9 # this is free software under the same license as perl itself
  10
  11 =head1 NAME
  12
  13 DBIx::Class::Schema::RestrictByUser - Automatically restrict resultsets by user
  14
  15 =head1 SYNOPSYS
  16
  17 In your L<DBIx::Class::Schema> class:
  18
  19    __PACKAGE__->load_components(qw/Schema::RestrictByUser/);
  20
  21 In the L<DBIx::Class> table class for your users:
  22
  23    #let's pretend a user has_many notes, which are in ResultSet 'Notes'
  24   sub restrict_Notes_resultset {
  25     my $self = shift; #the User object
  26     my $unrestricted_rs = shift;
  27
  28     #restrict the notes viewable to only those that belong to this user
  29     #this will, in effect make the following 2 equivalent
  30     # $user->notes $schema->resultset('Notes')
  31     return $self->related_resultset('notes');
  32   }
  33
  34    #it could also be written like this
  35   sub restrict_Notes_resultset {
  36     my $self = shift; #the User object
  37     my $unrestricted_rs = shift;
  38     return $unrestricted_rs->search_rs( { user_id => $self->id } );
  39   }
  40
  41 Wherever you connect to your database
  42
  43   my $schema = MyApp::Schema->connect(...);
  44   my $user = $schema->resultset('User')->find( { id => $user_id } );
  45   $resticted_schema = $schema->restrict_by_user( $user, $optional_prefix);
  46
  47 =cut
  48
  49 =head1 DESCRIPTION
  50
  51 This L<DBIx::Class::Schema> component can be used to restrict all resultsets through
  52 an appropriately-named method in a user's result_class. This can be done to
  53 automatically prevent data from being accessed by a user, effectively enforcing
  54 security by limiting any access to the data store.
  55
  56 =head1 PUBLIC METHODS
  57
  58 =head2 restrict_by_user $user_obj, $optional_prefix
  59
  60 Will restrict resultsets according to the methods available in $user_obj and
  61 return a restricted copy of itself. ResultSets will be restricted if methods
  62 in the form  of C<restrict_${ResultSet_Name}_resultset> are found in $user_obj.
  63 If the optional prefix is included it will attempt to use
  64 C<restrict_${prefix}_${ResultSet_Name}_resultset>, if that does not exist, it
  65 will try again without the prefix, and if that's not available the resultset
  66 will not be restricted.
  67
  68 =cut
  69
  70 sub restrict_by_user {
  71   my ($self, $user, $prefix) = @_;
  72   my $copy = $self->clone;
  73   $copy->make_restricted;
  74   $copy->user($user);
  75   $copy->restricted_prefix($prefix) if $prefix;
  76   return $copy;
  77 }
  78
  79 =head1 PRIVATE METHODS
  80
  81 =head2 make_restricted
  82
  83 Restrict the Schema class and ResultSources associated with this Schema
  84
  85 =cut
  86
  87 sub make_restricted {
  88   my ($self) = @_;
  89   my $class = ref($self);
  90   my $r_class = $self->_get_restricted_schema_class($class);
  91   bless($self, $r_class);
  92   foreach my $moniker ($self->sources) {
  93     my $source = $self->source($moniker);
  94     my $class = ref($source);
  95     my $r_class = $self->_get_restricted_source_class($class);
  96     bless($source, $r_class);
  97   }
  98 }
  99
 100 =head2 _get_restricted_schema_class $target_schema
 101
 102 Return the class name for the restricted schema class;
 103
 104 =cut
 105
 106 sub _get_restricted_schema_class {
 107   my ($self, $target) = @_;
 108   return $self->_get_restricted_class(Schema => $target);
 109 }
 110
 111 =head2 _get_restricted_source_class $target_source
 112
 113 Return the class name for the restricted ResultSource class;
 114
 115 =cut
 116
 117 sub _get_restricted_source_class {
 118   my ($self, $target) = @_;
 119   return $self->_get_restricted_class(Source => $target);
 120 }
 121
 122 =head2 _get_restrictedclass $type, $target
 123
 124 Return an appropriate class name for a restricted class of type $type.
 125
 126 =cut
 127
 128 sub _get_restricted_class {
 129   my ($self, $type, $target) = @_;
 130   my $r_class = join('::', $target, '__RestrictedByUser');
 131   unless (eval { $r_class->can('can') }) {
 132     my $r_comp = join(
 133       '::', 'DBIx::Class::Schema::RestrictByUser::RestrictComp', $type
 134     );
 135     $self->inject_base($r_class, $r_comp, $target);
 136   }
 137   return $r_class;
 138 }
 139
 140 1;
 141
 142 __END__;
 143
 144 =head1 SEE ALSO
 145
 146 L<DBIx::Class>, L<DBIx::Class::Schema::RestrictByUser::RestrictComp::Schema>,
 147 L<DBIx::Class::Schema::RestrictByUser::RestrictComp::Source>,
 148
 149 =head1 AUTHORS
 150
 151 Matt S Trout (mst) <mst@shadowcatsystems.co.uk>
 152
 153 With contributions from
 154 Guillermo Roditi (groditi) <groditi@cpan.org>
 155
 156 =head1 LICENSE
 157
 158 You may distribute this code under the same terms as Perl itself.
 159
 160 =cut