| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package CGI::Application::Plugin::Authorization; | 
| 2 |  |  |  |  |  |  |  | 
| 3 | 11 |  |  | 11 |  | 540780 | use strict; | 
|  | 11 |  |  |  |  | 34 |  | 
|  | 11 |  |  |  |  | 492 |  | 
| 4 | 11 |  |  | 11 |  | 65 | use vars qw($VERSION); | 
|  | 11 |  |  |  |  | 22 |  | 
|  | 11 |  |  |  |  | 1110 |  | 
| 5 |  |  |  |  |  |  | $VERSION = '0.07'; | 
| 6 |  |  |  |  |  |  |  | 
| 7 |  |  |  |  |  |  | our %__CONFIG; | 
| 8 |  |  |  |  |  |  |  | 
| 9 | 11 |  |  | 11 |  | 10241 | use UNIVERSAL::require; | 
|  | 11 |  |  |  |  | 21129 |  | 
|  | 11 |  |  |  |  | 129 |  | 
| 10 | 11 |  |  | 11 |  | 352 | use Scalar::Util; | 
|  | 11 |  |  |  |  | 23 |  | 
|  | 11 |  |  |  |  | 666 |  | 
| 11 | 11 |  |  | 11 |  | 113 | use List::Util qw(first); | 
|  | 11 |  |  |  |  | 24 |  | 
|  | 11 |  |  |  |  | 1455 |  | 
| 12 | 11 |  |  | 11 |  | 62 | use Carp; | 
|  | 11 |  |  |  |  | 24 |  | 
|  | 11 |  |  |  |  | 1011 |  | 
| 13 |  |  |  |  |  |  |  | 
| 14 |  |  |  |  |  |  | sub import { | 
| 15 | 15 |  |  | 15 |  | 21332 | my $pkg     = shift; | 
| 16 | 15 |  |  |  |  | 72 | my $callpkg = caller; | 
| 17 |  |  |  |  |  |  | { | 
| 18 | 11 |  |  | 11 |  | 60 | no strict qw(refs); | 
|  | 11 |  |  |  |  | 19 |  | 
|  | 11 |  |  |  |  | 6361 |  | 
|  | 15 |  |  |  |  | 228 |  | 
| 19 | 15 |  |  |  |  | 40 | *{ $callpkg . '::authz' } | 
|  | 15 |  |  |  |  | 106 |  | 
| 20 |  |  |  |  |  |  | = \&CGI::Application::Plugin::_::Authorization::authz; | 
| 21 | 15 |  |  |  |  | 33 | *{ $callpkg . '::authorization' } | 
|  | 15 |  |  |  |  | 93 |  | 
| 22 |  |  |  |  |  |  | = \&CGI::Application::Plugin::_::Authorization::authz; | 
| 23 |  |  |  |  |  |  | } | 
| 24 | 15 | 100 |  |  |  | 255 | if ( !UNIVERSAL::isa( $callpkg, 'CGI::Application' ) ) { | 
|  |  | 50 |  |  |  |  |  | 
| 25 | 1 |  |  |  |  | 13 | warn | 
| 26 |  |  |  |  |  |  | "Calling package is not a CGI::Application module so not setting up the prerun hook.  If you are using \@ISA instead of 'use base', make sure it is in a BEGIN { } block, and make sure these statements appear before the plugin is loaded"; | 
| 27 |  |  |  |  |  |  | } | 
| 28 |  |  |  |  |  |  | elsif ( !UNIVERSAL::can( $callpkg, 'add_callback' ) ) { | 
| 29 | 0 |  |  |  |  | 0 | warn | 
| 30 |  |  |  |  |  |  | "You are using an older version of CGI::Application that does not support callbacks, so the prerun method can not be registered automatically (Lookup 'CGI::Application CALLBACKS' in the docs for more info)"; | 
| 31 |  |  |  |  |  |  | } | 
| 32 |  |  |  |  |  |  | else { | 
| 33 | 14 |  |  |  |  | 83 | $callpkg->add_callback( prerun => \&prerun_callback ); | 
| 34 |  |  |  |  |  |  | } | 
| 35 |  |  |  |  |  |  | } | 
| 36 |  |  |  |  |  |  |  | 
| 37 |  |  |  |  |  |  | =head1 NAME | 
| 38 |  |  |  |  |  |  |  | 
| 39 |  |  |  |  |  |  | CGI::Application::Plugin::Authorization - Authorization framework for | 
| 40 |  |  |  |  |  |  | CGI::Application | 
| 41 |  |  |  |  |  |  |  | 
| 42 |  |  |  |  |  |  |  | 
| 43 |  |  |  |  |  |  | =head1 SYNOPSIS | 
| 44 |  |  |  |  |  |  |  | 
| 45 |  |  |  |  |  |  | use base qw(CGI::Application); | 
| 46 |  |  |  |  |  |  | use CGI::Application::Plugin::Authentication; | 
| 47 |  |  |  |  |  |  | use CGI::Application::Plugin::Authorization; | 
| 48 |  |  |  |  |  |  |  | 
| 49 |  |  |  |  |  |  | # default config for runmode authorization | 
| 50 |  |  |  |  |  |  | __PACKAGE__->authz->config( | 
| 51 |  |  |  |  |  |  | DRIVER => [ 'HTGroup', FILE => 'htgroup' ], | 
| 52 |  |  |  |  |  |  | ); | 
| 53 |  |  |  |  |  |  |  | 
| 54 |  |  |  |  |  |  | # Using a named configuration to distinguish it from | 
| 55 |  |  |  |  |  |  | # the above configuration | 
| 56 |  |  |  |  |  |  | __PACKAGE__->authz('dbaccess')->config( | 
| 57 |  |  |  |  |  |  | DRIVER => [ 'DBI', | 
| 58 |  |  |  |  |  |  | DBH   => $self->dbh, | 
| 59 |  |  |  |  |  |  | TABLES      => ['user', 'access'], | 
| 60 |  |  |  |  |  |  | JOIN_ON     => 'user.id = access.user_id', | 
| 61 |  |  |  |  |  |  | CONSTRAINTS => { | 
| 62 |  |  |  |  |  |  | 'user.name'      => '__USERNAME__', | 
| 63 |  |  |  |  |  |  | 'access.table'   => '__PARAM_1__', | 
| 64 |  |  |  |  |  |  | 'access.item_id' => '__PARAM_2__' | 
| 65 |  |  |  |  |  |  | } | 
| 66 |  |  |  |  |  |  | ], | 
| 67 |  |  |  |  |  |  | ); | 
| 68 |  |  |  |  |  |  |  | 
| 69 |  |  |  |  |  |  | sub admin_runmode { | 
| 70 |  |  |  |  |  |  | my $self = shift; | 
| 71 |  |  |  |  |  |  |  | 
| 72 |  |  |  |  |  |  | # User must be in the admin group to have access to this runmode | 
| 73 |  |  |  |  |  |  | return $self->authz->forbidden unless $self->authz->authorize('admin'); | 
| 74 |  |  |  |  |  |  |  | 
| 75 |  |  |  |  |  |  | # rest of the runmode | 
| 76 |  |  |  |  |  |  | ... | 
| 77 |  |  |  |  |  |  | } | 
| 78 |  |  |  |  |  |  |  | 
| 79 |  |  |  |  |  |  | sub update_widget { | 
| 80 |  |  |  |  |  |  | my $self = shift; | 
| 81 |  |  |  |  |  |  | my $widget = $self->query->param('widget_id'); | 
| 82 |  |  |  |  |  |  |  | 
| 83 |  |  |  |  |  |  | # Can this user edit this widget in the widgets table? | 
| 84 |  |  |  |  |  |  | return $self->authz->forbidden unless $self->authz('dbaccess')->authorize(widgets => $widget); | 
| 85 |  |  |  |  |  |  |  | 
| 86 |  |  |  |  |  |  | # save changes to the widget | 
| 87 |  |  |  |  |  |  | ... | 
| 88 |  |  |  |  |  |  | } | 
| 89 |  |  |  |  |  |  |  | 
| 90 |  |  |  |  |  |  | =head1 DESCRIPTION | 
| 91 |  |  |  |  |  |  |  | 
| 92 |  |  |  |  |  |  | CGI::Application::Plugin::Authorization adds the ability to authorize users for | 
| 93 |  |  |  |  |  |  | specific tasks.  Once a user has been authenticated and you know who you are | 
| 94 |  |  |  |  |  |  | dealing with, you can then use this plugin to control what that user has access | 
| 95 |  |  |  |  |  |  | to.  It imports two methods (C and C) into your | 
| 96 |  |  |  |  |  |  | L module.  Both of these methods are interchangeable, so you | 
| 97 |  |  |  |  |  |  | should choose one and use it consistently throughout your code.  Through the | 
| 98 |  |  |  |  |  |  | authz method you can call all the methods of the | 
| 99 |  |  |  |  |  |  | CGI::Application::Plugin::Authorization plugin. | 
| 100 |  |  |  |  |  |  |  | 
| 101 |  |  |  |  |  |  | =head2 Named Configurations | 
| 102 |  |  |  |  |  |  |  | 
| 103 |  |  |  |  |  |  | There could be multiple ways that you may want to authorize actions in | 
| 104 |  |  |  |  |  |  | different parts of your code.  These differences may conflict with each other. | 
| 105 |  |  |  |  |  |  | For example you may have runmode level authorization that requires that the | 
| 106 |  |  |  |  |  |  | user belongs to a certain group.  But secondly, you may have row level database | 
| 107 |  |  |  |  |  |  | authorization that requires that the username column of the table contains the | 
| 108 |  |  |  |  |  |  | name of the current user.  These configurations would conflict with each other | 
| 109 |  |  |  |  |  |  | since they are authorizing using different information.  To solve this you can | 
| 110 |  |  |  |  |  |  | create multiple named configurations, by specifying a unique name to the | 
| 111 |  |  |  |  |  |  | c method. | 
| 112 |  |  |  |  |  |  |  | 
| 113 |  |  |  |  |  |  | __PACKAGE__->authz('dbaccess')->config( | 
| 114 |  |  |  |  |  |  | DRIVER => [ 'DBI', ... ], | 
| 115 |  |  |  |  |  |  | ); | 
| 116 |  |  |  |  |  |  | # later | 
| 117 |  |  |  |  |  |  | $self->authz('dbaccess')->authorize(widgets => $widget_id); | 
| 118 |  |  |  |  |  |  |  | 
| 119 |  |  |  |  |  |  |  | 
| 120 |  |  |  |  |  |  |  | 
| 121 |  |  |  |  |  |  | =head1 EXPORTED METHODS | 
| 122 |  |  |  |  |  |  |  | 
| 123 |  |  |  |  |  |  | =head2 authz -and- authorization | 
| 124 |  |  |  |  |  |  |  | 
| 125 |  |  |  |  |  |  | These methods are interchangeable and provided for users that either prefer | 
| 126 |  |  |  |  |  |  | brevity, or clarity.  Everything is controlled through this method call, which | 
| 127 |  |  |  |  |  |  | will return a CGI::Application::Plugin::Authorization object, or just the class | 
| 128 |  |  |  |  |  |  | name if called as a class method.  When using the plugin, you will always first | 
| 129 |  |  |  |  |  |  | call $self->authz or __PACKAGE__->authz and then the method you wish to invoke. | 
| 130 |  |  |  |  |  |  | You can create multiple named authorization modules by providing a unique name | 
| 131 |  |  |  |  |  |  | to the call to authz.  This will allow you to handle different types of | 
| 132 |  |  |  |  |  |  | authorization in your modules.  For example, you could use the main | 
| 133 |  |  |  |  |  |  | configuration to do runmode level authorization, and use a named configuration | 
| 134 |  |  |  |  |  |  | to manage database row level authorization. | 
| 135 |  |  |  |  |  |  |  | 
| 136 |  |  |  |  |  |  |  | 
| 137 |  |  |  |  |  |  | =cut | 
| 138 |  |  |  |  |  |  |  | 
| 139 |  |  |  |  |  |  | { | 
| 140 |  |  |  |  |  |  | package    # Hide from PAUSE | 
| 141 |  |  |  |  |  |  | CGI::Application::Plugin::_::Authorization; | 
| 142 |  |  |  |  |  |  |  | 
| 143 |  |  |  |  |  |  | ############################################## | 
| 144 |  |  |  |  |  |  | ### | 
| 145 |  |  |  |  |  |  | ###   authorization | 
| 146 |  |  |  |  |  |  | ### | 
| 147 |  |  |  |  |  |  | ############################################## | 
| 148 |  |  |  |  |  |  | # | 
| 149 |  |  |  |  |  |  | # Return an authorization object that can be used | 
| 150 |  |  |  |  |  |  | # for managing authorization. | 
| 151 |  |  |  |  |  |  | # | 
| 152 |  |  |  |  |  |  | # This will return a class name if called | 
| 153 |  |  |  |  |  |  | # as a class, and a singleton object | 
| 154 |  |  |  |  |  |  | # if called as an object method | 
| 155 |  |  |  |  |  |  | # | 
| 156 |  |  |  |  |  |  | sub authz { | 
| 157 | 142 |  |  | 142 |  | 111427 | my $cgiapp = shift; | 
| 158 | 142 |  | 100 |  |  | 655 | my $name   = shift || '__default__'; | 
| 159 |  |  |  |  |  |  |  | 
| 160 | 142 | 100 |  |  |  | 332 | if ( ref($cgiapp) ) { | 
| 161 | 121 |  |  |  |  | 567 | return CGI::Application::Plugin::Authorization->instance( | 
| 162 |  |  |  |  |  |  | ref($cgiapp) . '-' . $name, $cgiapp ); | 
| 163 |  |  |  |  |  |  | } | 
| 164 |  |  |  |  |  |  | else { | 
| 165 | 21 |  |  |  |  | 205 | return CGI::Application::Plugin::Authorization->instance( | 
| 166 |  |  |  |  |  |  | $cgiapp . '-' . $name, $cgiapp ); | 
| 167 |  |  |  |  |  |  | } | 
| 168 |  |  |  |  |  |  | } | 
| 169 |  |  |  |  |  |  |  | 
| 170 |  |  |  |  |  |  | } | 
| 171 |  |  |  |  |  |  |  | 
| 172 |  |  |  |  |  |  | package CGI::Application::Plugin::Authorization; | 
| 173 |  |  |  |  |  |  |  | 
| 174 |  |  |  |  |  |  | =head1 METHODS | 
| 175 |  |  |  |  |  |  |  | 
| 176 |  |  |  |  |  |  | =head2 config | 
| 177 |  |  |  |  |  |  |  | 
| 178 |  |  |  |  |  |  | This method is used to configure the CGI::Application::Plugin::Authorization | 
| 179 |  |  |  |  |  |  | module.  It can be called as an object method, or as a class method. | 
| 180 |  |  |  |  |  |  |  | 
| 181 |  |  |  |  |  |  | The following parameters are accepted: | 
| 182 |  |  |  |  |  |  |  | 
| 183 |  |  |  |  |  |  | =over 4 | 
| 184 |  |  |  |  |  |  |  | 
| 185 |  |  |  |  |  |  | =item DRIVER | 
| 186 |  |  |  |  |  |  |  | 
| 187 |  |  |  |  |  |  | Here you can choose which authorization module(s) you want to use to perform | 
| 188 |  |  |  |  |  |  | the authorization.  For simplicity, you can leave off the | 
| 189 |  |  |  |  |  |  | CGI::Application::Plugin::Authorization::Driver:: part when specifying the | 
| 190 |  |  |  |  |  |  | DRIVER parameter.  If this module requires extra parameters, you can pass an | 
| 191 |  |  |  |  |  |  | array reference that contains as the first parameter the name of the module, | 
| 192 |  |  |  |  |  |  | and the required parameters as the rest of the array.  You can provide multiple | 
| 193 |  |  |  |  |  |  | drivers which will be used, in order, to check the permissions until a valid | 
| 194 |  |  |  |  |  |  | response is received. | 
| 195 |  |  |  |  |  |  |  | 
| 196 |  |  |  |  |  |  | DRIVER => [ 'DBI', dbh => $self->dbh ], | 
| 197 |  |  |  |  |  |  |  | 
| 198 |  |  |  |  |  |  | - or - | 
| 199 |  |  |  |  |  |  |  | 
| 200 |  |  |  |  |  |  | DRIVER => [ | 
| 201 |  |  |  |  |  |  | [ 'HTGroup', file => '.htgroup' ], | 
| 202 |  |  |  |  |  |  | [ 'LDAP', binddn => '...', host => 'localhost', ... ] | 
| 203 |  |  |  |  |  |  | ], | 
| 204 |  |  |  |  |  |  |  | 
| 205 |  |  |  |  |  |  |  | 
| 206 |  |  |  |  |  |  | =item FORBIDDEN_RUNMODE | 
| 207 |  |  |  |  |  |  |  | 
| 208 |  |  |  |  |  |  | Here you can specify a runmode that the user will be redirected to if they fail | 
| 209 |  |  |  |  |  |  | the authorization checks. | 
| 210 |  |  |  |  |  |  |  | 
| 211 |  |  |  |  |  |  | FORBIDDEN_RUNMODE => 'forbidden' | 
| 212 |  |  |  |  |  |  |  | 
| 213 |  |  |  |  |  |  | =item FORBIDDEN_URL | 
| 214 |  |  |  |  |  |  |  | 
| 215 |  |  |  |  |  |  | If your forbidden page is external to this module, then you can use this option | 
| 216 |  |  |  |  |  |  | to specify a URL that the user will be redirected to when they fail the | 
| 217 |  |  |  |  |  |  | authorization checks. If both FORBIDDEN_URL and FORBIDDEN_RUNMODE are | 
| 218 |  |  |  |  |  |  | specified, then the latter will take precedence. | 
| 219 |  |  |  |  |  |  |  | 
| 220 |  |  |  |  |  |  | FORBIDDEN_URL => 'http://example.com/forbidden.html' | 
| 221 |  |  |  |  |  |  |  | 
| 222 |  |  |  |  |  |  | =item GET_USERNAME | 
| 223 |  |  |  |  |  |  |  | 
| 224 |  |  |  |  |  |  | This option allows you to provide a method that should return us the username | 
| 225 |  |  |  |  |  |  | of the currently logged in user.  It will be passed the current authz objects | 
| 226 |  |  |  |  |  |  | as the only parameter.  This is not a required option, and can be omitted if | 
| 227 |  |  |  |  |  |  | you use the Authentication plugin, or if your authentication system sets | 
| 228 |  |  |  |  |  |  | $ENV{REMOTE_USER}. | 
| 229 |  |  |  |  |  |  |  | 
| 230 |  |  |  |  |  |  | GET_USERNAME => sub { my $authz = shift; return $authz->cgiapp->my_username } | 
| 231 |  |  |  |  |  |  |  | 
| 232 |  |  |  |  |  |  |  | 
| 233 |  |  |  |  |  |  | =back | 
| 234 |  |  |  |  |  |  |  | 
| 235 |  |  |  |  |  |  | =cut | 
| 236 |  |  |  |  |  |  |  | 
| 237 |  |  |  |  |  |  | sub config { | 
| 238 | 47 |  |  | 47 | 1 | 104 | my $self  = shift; | 
| 239 | 47 |  |  |  |  | 169 | my $class = ref $self; | 
| 240 |  |  |  |  |  |  |  | 
| 241 | 47 | 100 |  |  |  | 255 | die | 
| 242 |  |  |  |  |  |  | "Calling config after the Authorization object has already been created" | 
| 243 |  |  |  |  |  |  | if $self->{loaded}; | 
| 244 | 46 |  |  |  |  | 180 | my $config = $self->_config; | 
| 245 |  |  |  |  |  |  |  | 
| 246 | 46 | 100 |  |  |  | 122 | if (@_) { | 
| 247 | 45 |  |  |  |  | 57 | my $props; | 
| 248 | 45 | 100 |  |  |  | 414 | if ( ref( $_[0] ) eq 'HASH' ) { | 
| 249 | 2 |  |  |  |  | 3 | my $rthash = %{ $_[0] }; | 
|  | 2 |  |  |  |  | 9 |  | 
| 250 | 2 |  |  |  |  | 9 | $props = CGI::Application->_cap_hash( $_[0] ); | 
| 251 |  |  |  |  |  |  | } | 
| 252 |  |  |  |  |  |  | else { | 
| 253 | 43 |  |  |  |  | 304 | $props = CGI::Application->_cap_hash( {@_} ); | 
| 254 |  |  |  |  |  |  | } | 
| 255 |  |  |  |  |  |  |  | 
| 256 |  |  |  |  |  |  | # Check for DRIVER | 
| 257 | 45 | 100 |  |  |  | 859 | if ( defined $props->{DRIVER} ) { | 
| 258 | 36 | 100 | 100 |  |  | 305 | croak | 
| 259 |  |  |  |  |  |  | "authz config error:  parameter DRIVER is not a string or arrayref" | 
| 260 |  |  |  |  |  |  | if ref $props->{DRIVER} | 
| 261 |  |  |  |  |  |  | && Scalar::Util::reftype( $props->{DRIVER} ) ne 'ARRAY'; | 
| 262 | 35 |  |  |  |  | 125 | $config->{DRIVER} = delete $props->{DRIVER}; | 
| 263 |  |  |  |  |  |  | # We will accept a string, or an arrayref of options, but what we | 
| 264 |  |  |  |  |  |  | # really want is an array of arrayrefs of options, so that we can | 
| 265 |  |  |  |  |  |  | # support multiple drivers each with their own custom options | 
| 266 | 11 |  |  | 11 |  | 74 | no warnings qw(uninitialized); | 
|  | 11 |  |  |  |  | 22 |  | 
|  | 11 |  |  |  |  | 24464 |  | 
| 267 | 35 | 100 |  |  |  | 164 | $config->{DRIVER} = [ $config->{DRIVER} ] | 
| 268 |  |  |  |  |  |  | if Scalar::Util::reftype( $config->{DRIVER} ) ne 'ARRAY'; | 
| 269 | 35 | 100 |  |  |  | 228 | $config->{DRIVER} = [ $config->{DRIVER} ] | 
| 270 |  |  |  |  |  |  | if Scalar::Util::reftype( $config->{DRIVER}->[0] ) ne 'ARRAY'; | 
| 271 |  |  |  |  |  |  | } | 
| 272 |  |  |  |  |  |  |  | 
| 273 |  |  |  |  |  |  | # Check for FORBIDDEN_RUNMODE | 
| 274 | 44 | 100 |  |  |  | 137 | if ( defined $props->{FORBIDDEN_RUNMODE} ) { | 
| 275 | 4 | 100 |  |  |  | 30 | croak | 
| 276 |  |  |  |  |  |  | "authz config error:  parameter FORBIDDEN_RUNMODE is not a string" | 
| 277 |  |  |  |  |  |  | if ref $props->{FORBIDDEN_RUNMODE}; | 
| 278 | 3 |  |  |  |  | 11 | $config->{FORBIDDEN_RUNMODE} = delete $props->{FORBIDDEN_RUNMODE}; | 
| 279 |  |  |  |  |  |  | } | 
| 280 |  |  |  |  |  |  |  | 
| 281 |  |  |  |  |  |  | # Check for FORBIDDEN_URL | 
| 282 | 43 | 100 |  |  |  | 133 | if ( defined $props->{FORBIDDEN_URL} ) { | 
| 283 | 7 | 50 |  |  |  | 20 | carp | 
| 284 |  |  |  |  |  |  | "authz config warning:  parameter FORBIDDEN_URL ignored since we already have FORBIDDEN_RUNMODE" | 
| 285 |  |  |  |  |  |  | if $config->{FORBIDDEN_RUNMODE}; | 
| 286 | 7 | 100 |  |  |  | 29 | croak | 
| 287 |  |  |  |  |  |  | "authz config error:  parameter FORBIDDEN_URL is not a string" | 
| 288 |  |  |  |  |  |  | if ref $props->{FORBIDDEN_URL}; | 
| 289 | 6 |  |  |  |  | 18 | $config->{FORBIDDEN_URL} = delete $props->{FORBIDDEN_URL}; | 
| 290 |  |  |  |  |  |  | } | 
| 291 |  |  |  |  |  |  |  | 
| 292 |  |  |  |  |  |  | # Check for GET_USERNAME | 
| 293 | 42 | 100 |  |  |  | 120 | if ( defined $props->{GET_USERNAME} ) { | 
| 294 | 10 | 100 |  |  |  | 49 | croak | 
| 295 |  |  |  |  |  |  | "authz config error:  parameter GET_USERNAME is not a CODE reference" | 
| 296 |  |  |  |  |  |  | if ref $props->{GET_USERNAME} ne 'CODE'; | 
| 297 | 9 |  |  |  |  | 26 | $config->{GET_USERNAME} = delete $props->{GET_USERNAME}; | 
| 298 |  |  |  |  |  |  | } | 
| 299 |  |  |  |  |  |  |  | 
| 300 |  |  |  |  |  |  | # If there are still entries left in $props then they are invalid | 
| 301 | 41 | 100 |  |  |  | 230 | croak "Invalid option(s) (" | 
| 302 |  |  |  |  |  |  | . join( ', ', keys %$props ) | 
| 303 |  |  |  |  |  |  | . ") passed to config" | 
| 304 |  |  |  |  |  |  | if %$props; | 
| 305 |  |  |  |  |  |  | } | 
| 306 |  |  |  |  |  |  | } | 
| 307 |  |  |  |  |  |  |  | 
| 308 |  |  |  |  |  |  | =head2 authz_runmodes | 
| 309 |  |  |  |  |  |  |  | 
| 310 |  |  |  |  |  |  | This method takes a list of runmodes that are to be authorized, and | 
| 311 |  |  |  |  |  |  | the authorization rules for said runmodes.  If a user tries to access | 
| 312 |  |  |  |  |  |  | one of these runmodes, then they will be redirected to the forbidden | 
| 313 |  |  |  |  |  |  | page unless authorization is granted. | 
| 314 |  |  |  |  |  |  |  | 
| 315 |  |  |  |  |  |  | The runmode names can be simple strings, regular expressions, coderefs | 
| 316 |  |  |  |  |  |  | (which are passed the name of the runmode as their only parameter), or | 
| 317 |  |  |  |  |  |  | special directives that start with a colon. | 
| 318 |  |  |  |  |  |  |  | 
| 319 |  |  |  |  |  |  | The authorization rules can be simple strings representing the name of | 
| 320 |  |  |  |  |  |  | the group that the user must be a member of, as a list-ref of group | 
| 321 |  |  |  |  |  |  | names (of which the user only has to be a member of B | 
| 322 |  |  |  |  |  |  | groups>, or as a code-ref that will be called (with I parameters). | 
| 323 |  |  |  |  |  |  |  | 
| 324 |  |  |  |  |  |  | This method is cumulative, so if it is called multiple times, the new | 
| 325 |  |  |  |  |  |  | values are appended to the list of existing entries.  It returns a list | 
| 326 |  |  |  |  |  |  | containing all of the entries that have been configured thus far. | 
| 327 |  |  |  |  |  |  |  | 
| 328 |  |  |  |  |  |  | B compatibility with the interface as was defined in 0.06 B | 
| 329 |  |  |  |  |  |  | preserved.  0.06 allowed for runmodes to be passed in as a list-ref of | 
| 330 |  |  |  |  |  |  | two-element lists to specify authorization rules.  Although this | 
| 331 |  |  |  |  |  |  | interface is supported, the extra list-refs aren't necessary. | 
| 332 |  |  |  |  |  |  |  | 
| 333 |  |  |  |  |  |  | =over 4 | 
| 334 |  |  |  |  |  |  |  | 
| 335 |  |  |  |  |  |  | =item :all - All runmodes in this module will require authorization | 
| 336 |  |  |  |  |  |  |  | 
| 337 |  |  |  |  |  |  | =back | 
| 338 |  |  |  |  |  |  |  | 
| 339 |  |  |  |  |  |  | # match all runmodes | 
| 340 |  |  |  |  |  |  | __PACKAGE__->authz->authz_runmodes( | 
| 341 |  |  |  |  |  |  | ':all' => 'admin', | 
| 342 |  |  |  |  |  |  | ); | 
| 343 |  |  |  |  |  |  |  | 
| 344 |  |  |  |  |  |  | # only protect runmodes one and two | 
| 345 |  |  |  |  |  |  | __PACKAGE__->authz->authz_runmodes( | 
| 346 |  |  |  |  |  |  | one => 'admin', | 
| 347 |  |  |  |  |  |  | two => 'admin', | 
| 348 |  |  |  |  |  |  | ); | 
| 349 |  |  |  |  |  |  |  | 
| 350 |  |  |  |  |  |  | # protect only runmodes that start with auth_ | 
| 351 |  |  |  |  |  |  | __PACKAGE__->authz->authz_runmodes( | 
| 352 |  |  |  |  |  |  | qr/^authz_/ => 'admin', | 
| 353 |  |  |  |  |  |  | ); | 
| 354 |  |  |  |  |  |  |  | 
| 355 |  |  |  |  |  |  | # protect all runmodes that *do not* start with public_ | 
| 356 |  |  |  |  |  |  | __PACKAGE__->authz->authz_runmodes( | 
| 357 |  |  |  |  |  |  | qr/^(?!public_)/ => 'admin', | 
| 358 |  |  |  |  |  |  | ); | 
| 359 |  |  |  |  |  |  |  | 
| 360 |  |  |  |  |  |  | # preserve the interface from 0.06: | 
| 361 |  |  |  |  |  |  | __PACKAGE__->authz->authz_runmodes( | 
| 362 |  |  |  |  |  |  | [':all' => 'admin'], | 
| 363 |  |  |  |  |  |  | ); | 
| 364 |  |  |  |  |  |  |  | 
| 365 |  |  |  |  |  |  | =cut | 
| 366 |  |  |  |  |  |  |  | 
| 367 |  |  |  |  |  |  | sub authz_runmodes { | 
| 368 | 34 |  |  | 34 | 1 | 49 | my $self   = shift; | 
| 369 | 34 |  |  |  |  | 71 | my $config = $self->_config; | 
| 370 |  |  |  |  |  |  |  | 
| 371 | 34 |  | 100 |  |  | 126 | $config->{AUTHZ_RUNMODES} ||= []; | 
| 372 |  |  |  |  |  |  |  | 
| 373 | 34 |  |  |  |  | 90 | while (@_) { | 
| 374 | 33 |  |  |  |  | 33 | my ($rm, $group); | 
| 375 |  |  |  |  |  |  |  | 
| 376 |  |  |  |  |  |  | # extract next runmode/authz rule from args | 
| 377 | 33 | 100 |  |  |  | 72 | if (ref($_[0]) eq 'ARRAY') { | 
| 378 |  |  |  |  |  |  | # 0.06 interface; list-ref | 
| 379 | 3 |  |  |  |  | 4 | my $rule = shift @_; | 
| 380 | 3 |  |  |  |  | 4 | ($rm, $group) = @{$rule}; | 
|  | 3 |  |  |  |  | 10 |  | 
| 381 |  |  |  |  |  |  | } | 
| 382 |  |  |  |  |  |  | else { | 
| 383 |  |  |  |  |  |  | # new interface; list | 
| 384 | 30 |  |  |  |  | 46 | $rm = shift @_; | 
| 385 | 30 |  |  |  |  | 46 | $group = shift @_; | 
| 386 |  |  |  |  |  |  | } | 
| 387 |  |  |  |  |  |  |  | 
| 388 |  |  |  |  |  |  | # add authz rule to our config | 
| 389 | 33 |  |  |  |  | 39 | push( @{$config->{AUTHZ_RUNMODES}}, [$rm, $group] ); | 
|  | 33 |  |  |  |  | 143 |  | 
| 390 |  |  |  |  |  |  | } | 
| 391 |  |  |  |  |  |  |  | 
| 392 | 34 |  |  |  |  | 39 | return @{$config->{AUTHZ_RUNMODES}}; | 
|  | 34 |  |  |  |  | 125 |  | 
| 393 |  |  |  |  |  |  | } | 
| 394 |  |  |  |  |  |  |  | 
| 395 |  |  |  |  |  |  | =head2 is_authz_runmode | 
| 396 |  |  |  |  |  |  |  | 
| 397 |  |  |  |  |  |  | This method accepts the name of a runmode, and if that runmode requires | 
| 398 |  |  |  |  |  |  | authorization (ie the user needs to be a member of a particular group | 
| 399 |  |  |  |  |  |  | or has to satisfy some other authorization rule) then this method | 
| 400 |  |  |  |  |  |  | returns the corresponding authorization rule which must be satisfied | 
| 401 |  |  |  |  |  |  | (which could be either a scalar, a list-ref, or a code-ref, depending | 
| 402 |  |  |  |  |  |  | on how the rules were defined). | 
| 403 |  |  |  |  |  |  |  | 
| 404 |  |  |  |  |  |  | =cut | 
| 405 |  |  |  |  |  |  |  | 
| 406 |  |  |  |  |  |  | sub is_authz_runmode { | 
| 407 | 17 |  |  | 17 | 1 | 100 | my $self = shift; | 
| 408 | 17 |  |  |  |  | 26 | my $runmode = shift; | 
| 409 |  |  |  |  |  |  |  | 
| 410 | 17 |  |  |  |  | 46 | foreach my $runmode_info ($self->authz_runmodes) { | 
| 411 | 14 |  |  |  |  | 37 | my ($runmode_test, $rule) = @$runmode_info; | 
| 412 | 14 | 100 | 66 |  |  | 49 | if (overload::StrVal($runmode_test) =~ /^Regexp=/) { | 
|  |  | 100 |  |  |  |  |  | 
|  |  | 100 |  |  |  |  |  | 
| 413 |  |  |  |  |  |  | # We were passed a regular expression | 
| 414 | 2 | 50 |  |  |  | 30 | return $rule if $runmode =~ $runmode_test; | 
| 415 |  |  |  |  |  |  | } elsif (ref $runmode_test && ref $runmode_test eq 'CODE') { | 
| 416 |  |  |  |  |  |  | # We were passed a code reference | 
| 417 | 2 | 50 |  |  |  | 23 | return $rule if $runmode_test->($runmode); | 
| 418 |  |  |  |  |  |  | } elsif ($runmode_test eq ':all') { | 
| 419 |  |  |  |  |  |  | # all runmodes are protected | 
| 420 | 2 |  |  |  |  | 20 | return $rule; | 
| 421 |  |  |  |  |  |  | } else { | 
| 422 |  |  |  |  |  |  | # assume we were passed a string | 
| 423 | 8 | 50 |  |  |  | 120 | return $rule if $runmode eq $runmode_test; | 
| 424 |  |  |  |  |  |  | } | 
| 425 |  |  |  |  |  |  | } | 
| 426 |  |  |  |  |  |  |  | 
| 427 | 3 |  |  |  |  | 16 | return undef; | 
| 428 |  |  |  |  |  |  | } | 
| 429 |  |  |  |  |  |  |  | 
| 430 |  |  |  |  |  |  | =head2 new | 
| 431 |  |  |  |  |  |  |  | 
| 432 |  |  |  |  |  |  | This method creates a new L object. | 
| 433 |  |  |  |  |  |  | It requires as it's only parameter a L object.  This method | 
| 434 |  |  |  |  |  |  | should never be called directly, since the C method that is imported | 
| 435 |  |  |  |  |  |  | into the L module will take care of creating the | 
| 436 |  |  |  |  |  |  | L object when it is required. | 
| 437 |  |  |  |  |  |  |  | 
| 438 |  |  |  |  |  |  | =cut | 
| 439 |  |  |  |  |  |  |  | 
| 440 |  |  |  |  |  |  | sub new { | 
| 441 | 68 |  |  | 68 | 1 | 101 | my $class  = shift; | 
| 442 | 68 |  |  |  |  | 93 | my $name   = shift; | 
| 443 | 68 |  |  |  |  | 96 | my $cgiapp = shift; | 
| 444 | 68 |  |  |  |  | 118 | my $self   = {}; | 
| 445 |  |  |  |  |  |  |  | 
| 446 | 68 |  |  |  |  | 256 | bless $self, $class; | 
| 447 | 68 |  |  |  |  | 265 | $self->{name}   = $name; | 
| 448 | 68 |  |  |  |  | 139 | $self->{cgiapp} = $cgiapp; | 
| 449 | 68 | 100 |  |  |  | 317 | Scalar::Util::weaken( $self->{cgiapp} ) | 
| 450 |  |  |  |  |  |  | if ref $self->{cgiapp};    # weaken circular reference | 
| 451 |  |  |  |  |  |  |  | 
| 452 | 68 |  |  |  |  | 319 | return $self; | 
| 453 |  |  |  |  |  |  | } | 
| 454 |  |  |  |  |  |  |  | 
| 455 |  |  |  |  |  |  | =head2 instance | 
| 456 |  |  |  |  |  |  |  | 
| 457 |  |  |  |  |  |  | This method works the same way as C, except that it returns the same | 
| 458 |  |  |  |  |  |  | Authorization object for the duration of the request.  This method should never | 
| 459 |  |  |  |  |  |  | be called directly, since the C method that is imported into the | 
| 460 |  |  |  |  |  |  | L module will take care of creating the | 
| 461 |  |  |  |  |  |  | L object when it is required. | 
| 462 |  |  |  |  |  |  |  | 
| 463 |  |  |  |  |  |  | =cut | 
| 464 |  |  |  |  |  |  |  | 
| 465 |  |  |  |  |  |  | sub instance { | 
| 466 | 143 |  |  | 143 | 1 | 1910 | my $class  = shift; | 
| 467 | 143 |  | 100 |  |  | 376 | my $name   = shift ||''; | 
| 468 | 143 |  |  |  |  | 193 | my $cgiapp = shift; | 
| 469 | 143 | 100 | 100 |  |  | 1029 | die | 
| 470 |  |  |  |  |  |  | "CGI::Application::Plugin::Authorization->instance must be called with a CGI::Application object or class name" | 
| 471 |  |  |  |  |  |  | unless defined $cgiapp | 
| 472 |  |  |  |  |  |  | && UNIVERSAL::isa( $cgiapp, 'CGI::Application' ); | 
| 473 |  |  |  |  |  |  |  | 
| 474 | 141 | 100 |  |  |  | 329 | if ( ref $cgiapp ) { | 
| 475 |  |  |  |  |  |  | # being called from a CGI::Application object | 
| 476 | 120 | 100 |  |  |  | 549 | $cgiapp->{__CAP_AUTHORIZATION_INSTANCE}->{$name} | 
| 477 |  |  |  |  |  |  | = $class->new( $name, $cgiapp ) | 
| 478 |  |  |  |  |  |  | unless defined $cgiapp->{__CAP_AUTHORIZATION_INSTANCE}->{$name}; | 
| 479 | 120 |  |  |  |  | 731 | return $cgiapp->{__CAP_AUTHORIZATION_INSTANCE}->{$name}; | 
| 480 |  |  |  |  |  |  | } | 
| 481 |  |  |  |  |  |  | else { | 
| 482 |  |  |  |  |  |  | # being called from a CGI::Application class | 
| 483 | 21 |  |  |  |  | 76 | return $class->new( $name, $cgiapp ); | 
| 484 |  |  |  |  |  |  | } | 
| 485 |  |  |  |  |  |  | } | 
| 486 |  |  |  |  |  |  |  | 
| 487 |  |  |  |  |  |  | =head2 authorize | 
| 488 |  |  |  |  |  |  |  | 
| 489 |  |  |  |  |  |  | This method will test to see if the current user has access to the given | 
| 490 |  |  |  |  |  |  | resource.  It will take the given parameters and test them against the DRIVER | 
| 491 |  |  |  |  |  |  | classes that have been configured.  A true return value means the user should | 
| 492 |  |  |  |  |  |  | have access to the given resource. | 
| 493 |  |  |  |  |  |  |  | 
| 494 |  |  |  |  |  |  | # is the current user in the admin group | 
| 495 |  |  |  |  |  |  | if ($self->authz->authorize('admingroup')) { | 
| 496 |  |  |  |  |  |  | # perform an admin action | 
| 497 |  |  |  |  |  |  | } | 
| 498 |  |  |  |  |  |  |  | 
| 499 |  |  |  |  |  |  | =cut | 
| 500 |  |  |  |  |  |  |  | 
| 501 |  |  |  |  |  |  | sub authorize { | 
| 502 | 38 |  |  | 38 | 1 | 56 | my $self   = shift; | 
| 503 | 38 |  |  |  |  | 81 | my @params = @_; | 
| 504 |  |  |  |  |  |  |  | 
| 505 | 38 |  |  |  |  | 101 | foreach my $driver ( $self->drivers ) { | 
| 506 | 36 | 100 |  |  |  | 148 | return 1 if $driver->authorize(@params); | 
| 507 |  |  |  |  |  |  | } | 
| 508 | 19 |  |  |  |  | 61 | return 0; | 
| 509 |  |  |  |  |  |  | } | 
| 510 |  |  |  |  |  |  |  | 
| 511 |  |  |  |  |  |  | =head2 username | 
| 512 |  |  |  |  |  |  |  | 
| 513 |  |  |  |  |  |  | This method will return the name of the currently logged in user.  It uses | 
| 514 |  |  |  |  |  |  | three different methods to figure out the username: | 
| 515 |  |  |  |  |  |  |  | 
| 516 |  |  |  |  |  |  | =over 4 | 
| 517 |  |  |  |  |  |  |  | 
| 518 |  |  |  |  |  |  | =item GET_USERNAME option | 
| 519 |  |  |  |  |  |  |  | 
| 520 |  |  |  |  |  |  | Use the subroutine provided by the GET_USERNAME option to figure out the | 
| 521 |  |  |  |  |  |  | current username | 
| 522 |  |  |  |  |  |  |  | 
| 523 |  |  |  |  |  |  | =item CGI::Application::Plugin::Authentication | 
| 524 |  |  |  |  |  |  |  | 
| 525 |  |  |  |  |  |  | See if the L plugin is being used, | 
| 526 |  |  |  |  |  |  | and retrieve the username through this plugin | 
| 527 |  |  |  |  |  |  |  | 
| 528 |  |  |  |  |  |  | =item REMOTE_USER | 
| 529 |  |  |  |  |  |  |  | 
| 530 |  |  |  |  |  |  | See if the REMOTE_USER environment variable is set and use that value | 
| 531 |  |  |  |  |  |  |  | 
| 532 |  |  |  |  |  |  | =back | 
| 533 |  |  |  |  |  |  |  | 
| 534 |  |  |  |  |  |  | =cut | 
| 535 |  |  |  |  |  |  |  | 
| 536 |  |  |  |  |  |  | sub username { | 
| 537 | 39 |  |  | 39 | 1 | 60 | my $self   = shift; | 
| 538 | 39 |  |  |  |  | 162 | my $config = $self->_config; | 
| 539 |  |  |  |  |  |  |  | 
| 540 | 39 | 100 |  |  |  | 128 | if ( $config->{GET_USERNAME} ) { | 
|  |  | 100 |  |  |  |  |  | 
| 541 | 17 |  |  |  |  | 54 | return $config->{GET_USERNAME}->($self); | 
| 542 |  |  |  |  |  |  | } | 
| 543 |  |  |  |  |  |  | elsif ( $self->cgiapp->can('authen') ) { | 
| 544 | 1 |  |  |  |  | 5 | return $self->cgiapp->authen->username; | 
| 545 |  |  |  |  |  |  | } | 
| 546 |  |  |  |  |  |  | else { | 
| 547 | 21 |  |  |  |  | 110 | return $ENV{REMOTE_USER}; | 
| 548 |  |  |  |  |  |  | } | 
| 549 |  |  |  |  |  |  | } | 
| 550 |  |  |  |  |  |  |  | 
| 551 |  |  |  |  |  |  | =head2 drivers | 
| 552 |  |  |  |  |  |  |  | 
| 553 |  |  |  |  |  |  | This method will return a list of driver objects that are used for | 
| 554 |  |  |  |  |  |  | this authorization instance. | 
| 555 |  |  |  |  |  |  |  | 
| 556 |  |  |  |  |  |  | =cut | 
| 557 |  |  |  |  |  |  |  | 
| 558 |  |  |  |  |  |  | sub drivers { | 
| 559 | 42 |  |  | 42 | 1 | 422 | my $self = shift; | 
| 560 |  |  |  |  |  |  |  | 
| 561 | 42 | 100 |  |  |  | 130 | if ( !$self->{drivers} ) { | 
| 562 | 27 |  |  |  |  | 63 | my $config = $self->_config; | 
| 563 |  |  |  |  |  |  |  | 
| 564 |  |  |  |  |  |  | # Fetch the configuration parameters for the driver(s) | 
| 565 | 27 | 100 |  |  |  | 90 | my $driver_configs | 
| 566 |  |  |  |  |  |  | = defined $config->{DRIVER} ? $config->{DRIVER} : [ ['Dummy'] ]; | 
| 567 |  |  |  |  |  |  |  | 
| 568 | 27 |  |  |  |  | 63 | foreach my $driver_config (@$driver_configs) { | 
| 569 | 28 |  |  |  |  | 65 | my ( $drivername, @params ) = @$driver_config; | 
| 570 |  |  |  |  |  |  | # Load the the class for this driver | 
| 571 | 28 |  | 100 |  |  | 130 | my $driver_class = _find_delegate_class( | 
| 572 |  |  |  |  |  |  | 'CGI::Application::Plugin::Authorization::Driver::' | 
| 573 |  |  |  |  |  |  | . $drivername, $drivername | 
| 574 |  |  |  |  |  |  | ) | 
| 575 |  |  |  |  |  |  | || die "Driver " . $drivername . " can not be found"; | 
| 576 |  |  |  |  |  |  |  | 
| 577 |  |  |  |  |  |  | # Create the driver object | 
| 578 | 27 |  | 100 |  |  | 1520 | my $driver = $driver_class->new( $self, @params ) | 
| 579 |  |  |  |  |  |  | || die "Could not create new $driver_class object"; | 
| 580 | 26 |  |  |  |  | 41 | push @{ $self->{drivers} }, $driver; | 
|  | 26 |  |  |  |  | 132 |  | 
| 581 |  |  |  |  |  |  | } | 
| 582 | 25 |  |  |  |  | 74 | $self->{loaded} = 1; | 
| 583 |  |  |  |  |  |  | } | 
| 584 |  |  |  |  |  |  |  | 
| 585 | 40 |  |  |  |  | 71 | my $drivers = $self->{drivers}; | 
| 586 | 40 |  |  |  |  | 161 | return @$drivers[ 0 .. $#$drivers ]; | 
| 587 |  |  |  |  |  |  | } | 
| 588 |  |  |  |  |  |  |  | 
| 589 |  |  |  |  |  |  | =head2 cgiapp | 
| 590 |  |  |  |  |  |  |  | 
| 591 |  |  |  |  |  |  | This will return the underlying CGI::Application object. | 
| 592 |  |  |  |  |  |  |  | 
| 593 |  |  |  |  |  |  | =cut | 
| 594 |  |  |  |  |  |  |  | 
| 595 |  |  |  |  |  |  | sub cgiapp { | 
| 596 | 228 |  |  | 228 | 1 | 850 | return $_[0]->{cgiapp}; | 
| 597 |  |  |  |  |  |  | } | 
| 598 |  |  |  |  |  |  |  | 
| 599 |  |  |  |  |  |  |  | 
| 600 |  |  |  |  |  |  | =head2 setup_runmodes | 
| 601 |  |  |  |  |  |  |  | 
| 602 |  |  |  |  |  |  | This method is called during the prerun stage to register some custom | 
| 603 |  |  |  |  |  |  | runmodes that the Authentication plugin requires in order to function. | 
| 604 |  |  |  |  |  |  |  | 
| 605 |  |  |  |  |  |  | =cut | 
| 606 |  |  |  |  |  |  |  | 
| 607 |  |  |  |  |  |  | sub setup_runmodes { | 
| 608 | 17 |  |  | 17 | 1 | 112 | my $self = shift; | 
| 609 | 17 |  |  |  |  | 36 | $self->cgiapp->run_modes( authz_dummy_redirect => \&authz_dummy_redirect ); | 
| 610 | 17 |  |  |  |  | 367 | $self->cgiapp->run_modes( authz_forbidden      => \&authz_forbidden ); | 
| 611 | 17 |  |  |  |  | 300 | return; | 
| 612 |  |  |  |  |  |  | } | 
| 613 |  |  |  |  |  |  |  | 
| 614 |  |  |  |  |  |  | =head1 CGI::Application CALLBACKS | 
| 615 |  |  |  |  |  |  |  | 
| 616 |  |  |  |  |  |  | We'll automatically add the C run mode if you are using | 
| 617 |  |  |  |  |  |  | CGI::Application 4.0 or greater. | 
| 618 |  |  |  |  |  |  |  | 
| 619 |  |  |  |  |  |  | If you are using an older version of CGI::Application you will need to add it yourself. | 
| 620 |  |  |  |  |  |  |  | 
| 621 |  |  |  |  |  |  | sub cgiapp_prerun { | 
| 622 |  |  |  |  |  |  | my $self = shift; | 
| 623 |  |  |  |  |  |  |  | 
| 624 |  |  |  |  |  |  | $self->run_modes( authz_forbidden => \&CGI::Application::Plugin::Authorization::authz_forbidden, ); | 
| 625 |  |  |  |  |  |  | } | 
| 626 |  |  |  |  |  |  |  | 
| 627 |  |  |  |  |  |  | =cut | 
| 628 |  |  |  |  |  |  |  | 
| 629 |  |  |  |  |  |  | =head2 prerun_callback | 
| 630 |  |  |  |  |  |  |  | 
| 631 |  |  |  |  |  |  | This method is a CGI::Application prerun callback that will be | 
| 632 |  |  |  |  |  |  | automatically registered for you if you are using CGI::Application | 
| 633 |  |  |  |  |  |  | 4.0 or greater.  If you are using an older version of CGI::Application | 
| 634 |  |  |  |  |  |  | you will have to create your own cgiapp_prerun method and make sure you | 
| 635 |  |  |  |  |  |  | call this method from there. | 
| 636 |  |  |  |  |  |  |  | 
| 637 |  |  |  |  |  |  | sub cgiapp_prerun { | 
| 638 |  |  |  |  |  |  | my $self = shift; | 
| 639 |  |  |  |  |  |  |  | 
| 640 |  |  |  |  |  |  | $self->CGI::Application::Plugin::Authorization::prerun_callback(); | 
| 641 |  |  |  |  |  |  | } | 
| 642 |  |  |  |  |  |  |  | 
| 643 |  |  |  |  |  |  | =cut | 
| 644 |  |  |  |  |  |  |  | 
| 645 |  |  |  |  |  |  | sub prerun_callback { | 
| 646 | 17 |  |  | 17 | 1 | 51239 | my $self = shift; | 
| 647 | 17 |  |  |  |  | 46 | my $authz = $self->authz; | 
| 648 | 17 |  |  |  |  | 33 | my $rule = undef; | 
| 649 |  |  |  |  |  |  |  | 
| 650 |  |  |  |  |  |  | # setup the default login and logout runmodes | 
| 651 | 17 |  |  |  |  | 44 | $authz->setup_runmodes; | 
| 652 |  |  |  |  |  |  |  | 
| 653 | 17 | 100 |  |  |  | 77 | if ($rule = $authz->is_authz_runmode($self->get_current_runmode)) { | 
| 654 |  |  |  |  |  |  | # This runmode requires authorization | 
| 655 |  |  |  |  |  |  | my $authz_ok = ref($rule) eq 'CODE'   ? $rule->() | 
| 656 | 14 | 100 |  | 9 |  | 90 | : ref($rule) eq 'ARRAY'  ? first { $self->authz->authorize($_) } @{$rule} | 
|  | 9 | 100 |  |  |  | 23 |  | 
|  | 2 |  |  |  |  | 18 |  | 
| 657 |  |  |  |  |  |  | :                          $self->authz->authorize($rule); | 
| 658 | 14 | 100 |  |  |  | 171 | return $self->authz->redirect_to_forbidden | 
| 659 |  |  |  |  |  |  | unless ($authz_ok); | 
| 660 |  |  |  |  |  |  | } | 
| 661 |  |  |  |  |  |  | } | 
| 662 |  |  |  |  |  |  |  | 
| 663 |  |  |  |  |  |  | =head2 redirect_to_forbidden | 
| 664 |  |  |  |  |  |  |  | 
| 665 |  |  |  |  |  |  | This method is be called during the prerun stage if | 
| 666 |  |  |  |  |  |  | the current user is not authorized, and they are trying to | 
| 667 |  |  |  |  |  |  | access an authz runmode.  It will redirect to the page | 
| 668 |  |  |  |  |  |  | that has been configured as the forbidden page, based on the value | 
| 669 |  |  |  |  |  |  | of FORBIDDEN_RUNMODE or FORBIDDEN_URL  If nothing is configured | 
| 670 |  |  |  |  |  |  | then the default forbidden page will be used. | 
| 671 |  |  |  |  |  |  |  | 
| 672 |  |  |  |  |  |  | =cut | 
| 673 |  |  |  |  |  |  |  | 
| 674 |  |  |  |  |  |  | sub redirect_to_forbidden { | 
| 675 | 7 |  |  | 7 | 1 | 12 | my $self = shift; | 
| 676 | 7 |  |  |  |  | 13 | my $cgiapp = $self->cgiapp; | 
| 677 | 7 |  |  |  |  | 15 | my $config = $self->_config; | 
| 678 |  |  |  |  |  |  |  | 
| 679 | 7 | 50 |  |  |  | 26 | if ($config->{FORBIDDEN_RUNMODE}) { | 
|  |  | 50 |  |  |  |  |  | 
| 680 | 0 |  |  |  |  | 0 | $cgiapp->prerun_mode($config->{FORBIDDEN_RUNMODE}); | 
| 681 |  |  |  |  |  |  | } elsif ($config->{FORBIDDEN_URL}) { | 
| 682 | 0 |  |  |  |  | 0 | $cgiapp->header_add(-location => $config->{FORBIDDEN_URL}); | 
| 683 | 0 |  |  |  |  | 0 | $cgiapp->header_type('redirect'); | 
| 684 | 0 |  |  |  |  | 0 | $cgiapp->prerun_mode('authz_dummy_redirect'); | 
| 685 |  |  |  |  |  |  | } else { | 
| 686 | 7 |  |  |  |  | 21 | $cgiapp->prerun_mode('authz_forbidden'); | 
| 687 |  |  |  |  |  |  | } | 
| 688 |  |  |  |  |  |  | } | 
| 689 |  |  |  |  |  |  |  | 
| 690 |  |  |  |  |  |  | =head2 forbidden | 
| 691 |  |  |  |  |  |  |  | 
| 692 |  |  |  |  |  |  | This will return a forbidden page.  It checks the configuration to see if there | 
| 693 |  |  |  |  |  |  | is a custom runmode or URL to redirect to, otherwise it calls the builtin | 
| 694 |  |  |  |  |  |  | authz_forbidden runmode. | 
| 695 |  |  |  |  |  |  |  | 
| 696 |  |  |  |  |  |  | =cut | 
| 697 |  |  |  |  |  |  |  | 
| 698 |  |  |  |  |  |  | sub forbidden { | 
| 699 | 3 |  |  | 3 | 1 | 5 | my $self   = shift; | 
| 700 | 3 |  |  |  |  | 8 | my $cgiapp = $self->cgiapp; | 
| 701 | 3 |  |  |  |  | 7 | my $config = $self->_config; | 
| 702 |  |  |  |  |  |  |  | 
| 703 | 3 | 100 |  |  |  | 16 | if ( $config->{FORBIDDEN_RUNMODE} ) { | 
|  |  | 100 |  |  |  |  |  | 
| 704 | 1 |  |  |  |  | 4 | my $runmode = $config->{FORBIDDEN_RUNMODE}; | 
| 705 | 1 |  |  |  |  | 5 | return $cgiapp->$runmode(); | 
| 706 |  |  |  |  |  |  | } | 
| 707 |  |  |  |  |  |  | elsif ( $config->{FORBIDDEN_URL} ) { | 
| 708 | 1 |  |  |  |  | 9 | $cgiapp->header_add( -location => $config->{FORBIDDEN_URL} ); | 
| 709 | 1 |  |  |  |  | 43 | $cgiapp->header_type('redirect'); | 
| 710 | 1 |  |  |  |  | 14 | return; | 
| 711 |  |  |  |  |  |  | } | 
| 712 |  |  |  |  |  |  | else { | 
| 713 | 1 |  |  |  |  | 3 | return authz_forbidden( $self->cgiapp ); | 
| 714 |  |  |  |  |  |  | } | 
| 715 |  |  |  |  |  |  | } | 
| 716 |  |  |  |  |  |  |  | 
| 717 |  |  |  |  |  |  | =head1 CGI::Application RUNMODES | 
| 718 |  |  |  |  |  |  |  | 
| 719 |  |  |  |  |  |  | =head2 authz_forbidden | 
| 720 |  |  |  |  |  |  |  | 
| 721 |  |  |  |  |  |  | This runmode is provided if you do not want to create your own forbidden | 
| 722 |  |  |  |  |  |  | runmode.  It will display a simple error page to the user. | 
| 723 |  |  |  |  |  |  |  | 
| 724 |  |  |  |  |  |  | =cut | 
| 725 |  |  |  |  |  |  |  | 
| 726 |  |  |  |  |  |  | sub authz_forbidden { | 
| 727 | 8 |  |  | 8 | 1 | 533 | my $self = shift; | 
| 728 | 8 |  |  |  |  | 26 | my $q    = $self->query; | 
| 729 |  |  |  |  |  |  |  | 
| 730 | 8 |  |  |  |  | 1084 | my $html = join( | 
| 731 |  |  |  |  |  |  | "\n", | 
| 732 |  |  |  |  |  |  | CGI::start_html( | 
| 733 |  |  |  |  |  |  | -title => 'Forbidden', | 
| 734 |  |  |  |  |  |  | #-style  => { -code => $self->auth->styles }, | 
| 735 |  |  |  |  |  |  | ), | 
| 736 |  |  |  |  |  |  | CGI::h2('Forbidden'), | 
| 737 |  |  |  |  |  |  | CGI::p('You do not have permission to perform that action'), | 
| 738 |  |  |  |  |  |  | CGI::end_html(), | 
| 739 |  |  |  |  |  |  | ); | 
| 740 |  |  |  |  |  |  |  | 
| 741 | 8 |  |  |  |  | 13241 | return $html; | 
| 742 |  |  |  |  |  |  | } | 
| 743 |  |  |  |  |  |  |  | 
| 744 |  |  |  |  |  |  | =head2 authz_dummy_redirect | 
| 745 |  |  |  |  |  |  |  | 
| 746 |  |  |  |  |  |  | This runmode is provided for convenience when an external redirect needs | 
| 747 |  |  |  |  |  |  | to be done.  It just returns an empty string. | 
| 748 |  |  |  |  |  |  |  | 
| 749 |  |  |  |  |  |  | =cut | 
| 750 |  |  |  |  |  |  |  | 
| 751 |  |  |  |  |  |  | sub authz_dummy_redirect { | 
| 752 | 0 |  |  | 0 | 1 | 0 | return ''; | 
| 753 |  |  |  |  |  |  | } | 
| 754 |  |  |  |  |  |  |  | 
| 755 |  |  |  |  |  |  | ### | 
| 756 |  |  |  |  |  |  | ### Helper methods | 
| 757 |  |  |  |  |  |  | ### | 
| 758 |  |  |  |  |  |  |  | 
| 759 |  |  |  |  |  |  | sub _find_delegate_class { | 
| 760 | 28 |  |  | 28 |  | 58 | foreach my $class (@_) { | 
| 761 | 30 | 100 |  |  |  | 224 | $class->require && return $class; | 
| 762 |  |  |  |  |  |  | } | 
| 763 | 1 |  |  |  |  | 26 | return; | 
| 764 |  |  |  |  |  |  | } | 
| 765 |  |  |  |  |  |  |  | 
| 766 |  |  |  |  |  |  | sub _config { | 
| 767 | 156 |  |  | 156 |  | 206 | my $self = shift; | 
| 768 | 156 |  |  |  |  | 250 | my $name = $self->{name}; | 
| 769 | 156 |  |  |  |  | 177 | my $config; | 
| 770 | 156 | 100 |  |  |  | 346 | if ( ref $self->cgiapp ) { | 
| 771 | 136 |  | 100 |  |  | 621 | $config = $self->{__CAP_AUTHORIZATION_CONFIG} ||= $__CONFIG{$name} | 
|  |  |  | 66 |  |  |  |  | 
| 772 |  |  |  |  |  |  | || {}; | 
| 773 |  |  |  |  |  |  | } | 
| 774 |  |  |  |  |  |  | else { | 
| 775 | 20 |  | 100 |  |  | 113 | $__CONFIG{$name} ||= {}; | 
| 776 | 20 |  |  |  |  | 40 | $config = $__CONFIG{$name}; | 
| 777 |  |  |  |  |  |  | } | 
| 778 | 156 |  |  |  |  | 350 | return $config; | 
| 779 |  |  |  |  |  |  | } | 
| 780 |  |  |  |  |  |  |  | 
| 781 |  |  |  |  |  |  | =head1 EXAMPLE | 
| 782 |  |  |  |  |  |  |  | 
| 783 |  |  |  |  |  |  | In a CGI::Application module: | 
| 784 |  |  |  |  |  |  |  | 
| 785 |  |  |  |  |  |  | package MyCGIApp; | 
| 786 |  |  |  |  |  |  |  | 
| 787 |  |  |  |  |  |  | use base qw(CGI::Application); | 
| 788 |  |  |  |  |  |  | use CGI::Application::Plugin::AutoRunmode; | 
| 789 |  |  |  |  |  |  | use CGI::Application::Plugin::Authentication; | 
| 790 |  |  |  |  |  |  | use CGI::Application::Plugin::Authorization; | 
| 791 |  |  |  |  |  |  |  | 
| 792 |  |  |  |  |  |  | # Configure Authentication | 
| 793 |  |  |  |  |  |  | MyCGIApp->authen->config( | 
| 794 |  |  |  |  |  |  | DRIVER => 'Dummy', | 
| 795 |  |  |  |  |  |  | ); | 
| 796 |  |  |  |  |  |  | MyCGIApp->authen->protected_runmodes(qr/^admin_/); | 
| 797 |  |  |  |  |  |  |  | 
| 798 |  |  |  |  |  |  | # Configure Authorization (manages runmode authorization) | 
| 799 |  |  |  |  |  |  | MyCGIApp->authz->config( | 
| 800 |  |  |  |  |  |  | DRIVER => [ 'DBI', | 
| 801 |  |  |  |  |  |  | DBH         => $self->dbh, | 
| 802 |  |  |  |  |  |  | TABLES      => ['user', 'usergroup', 'group'], | 
| 803 |  |  |  |  |  |  | JOIN_ON     => 'user.id = usergroup.user_id AND usergroup.group_id = group.id', | 
| 804 |  |  |  |  |  |  | CONSTRAINTS => { | 
| 805 |  |  |  |  |  |  | 'user.name'  => '__USERNAME__', | 
| 806 |  |  |  |  |  |  | 'group.name' => '__GROUP__', | 
| 807 |  |  |  |  |  |  | } | 
| 808 |  |  |  |  |  |  | ], | 
| 809 |  |  |  |  |  |  | ); | 
| 810 |  |  |  |  |  |  | MyCGIApp->authz->authz_runmodes( | 
| 811 |  |  |  |  |  |  | [a_runmode => 'a_group'], | 
| 812 |  |  |  |  |  |  | [qr/^admin_/ => 'admin'], | 
| 813 |  |  |  |  |  |  | [':all' => 'all_group'], | 
| 814 |  |  |  |  |  |  | [sub {my $rm = shift; return ($rm eq "dangerous_rm")} => 'super_group'], | 
| 815 |  |  |  |  |  |  | ); | 
| 816 |  |  |  |  |  |  |  | 
| 817 |  |  |  |  |  |  | # Configure second Authorization module using a named configuration | 
| 818 |  |  |  |  |  |  | __PACKAGE__->authz('dbaccess')->config( | 
| 819 |  |  |  |  |  |  | DRIVER => [ 'DBI', | 
| 820 |  |  |  |  |  |  | DBH   => $self->dbh, | 
| 821 |  |  |  |  |  |  | TABLES      => ['user', 'access'], | 
| 822 |  |  |  |  |  |  | JOIN_ON     => 'user.id = access.user_id', | 
| 823 |  |  |  |  |  |  | CONSTRAINTS => { | 
| 824 |  |  |  |  |  |  | 'user.name'      => '__USERNAME__', | 
| 825 |  |  |  |  |  |  | 'access.table'   => '__PARAM_1__', | 
| 826 |  |  |  |  |  |  | 'access.item_id' => '__PARAM_2__' | 
| 827 |  |  |  |  |  |  | } | 
| 828 |  |  |  |  |  |  | ], | 
| 829 |  |  |  |  |  |  | ); | 
| 830 |  |  |  |  |  |  |  | 
| 831 |  |  |  |  |  |  | sub start : Runmode { | 
| 832 |  |  |  |  |  |  | my $self = shift; | 
| 833 |  |  |  |  |  |  |  | 
| 834 |  |  |  |  |  |  | } | 
| 835 |  |  |  |  |  |  |  | 
| 836 |  |  |  |  |  |  | sub admin_one : Runmode { | 
| 837 |  |  |  |  |  |  | my $self = shift; | 
| 838 |  |  |  |  |  |  | # The user will only get here if they are logged in and | 
| 839 |  |  |  |  |  |  | # belong to the admin group | 
| 840 |  |  |  |  |  |  |  | 
| 841 |  |  |  |  |  |  | } | 
| 842 |  |  |  |  |  |  |  | 
| 843 |  |  |  |  |  |  | sub admin_widgets : Runmode { | 
| 844 |  |  |  |  |  |  | my $self = shift; | 
| 845 |  |  |  |  |  |  | # The user will only get here if they are logged in and | 
| 846 |  |  |  |  |  |  | # belong to the admin group | 
| 847 |  |  |  |  |  |  |  | 
| 848 |  |  |  |  |  |  | # Can this user edit this widget in the widgets table? | 
| 849 |  |  |  |  |  |  | my $widget_id = $self->query->param('widget_id'); | 
| 850 |  |  |  |  |  |  | return $self->authz->forbidden unless $self->authz('dbaccess')->authorize(widgets => $widget_id); | 
| 851 |  |  |  |  |  |  |  | 
| 852 |  |  |  |  |  |  | } | 
| 853 |  |  |  |  |  |  |  | 
| 854 |  |  |  |  |  |  |  | 
| 855 |  |  |  |  |  |  | =head1 TODO | 
| 856 |  |  |  |  |  |  |  | 
| 857 |  |  |  |  |  |  | The module is definately in a usable state, but there are still some parts | 
| 858 |  |  |  |  |  |  | missing that I would like to add in: | 
| 859 |  |  |  |  |  |  |  | 
| 860 |  |  |  |  |  |  | =over 4 | 
| 861 |  |  |  |  |  |  |  | 
| 862 |  |  |  |  |  |  | =item provide easy methods for authorizing runmode access automatically | 
| 863 |  |  |  |  |  |  |  | 
| 864 |  |  |  |  |  |  | =item allow subroutine attributes to configure authorization for a runmode | 
| 865 |  |  |  |  |  |  |  | 
| 866 |  |  |  |  |  |  | =item write a tutorial/cookbook to include with the docs | 
| 867 |  |  |  |  |  |  |  | 
| 868 |  |  |  |  |  |  | =back | 
| 869 |  |  |  |  |  |  |  | 
| 870 |  |  |  |  |  |  |  | 
| 871 |  |  |  |  |  |  | =head1 BUGS | 
| 872 |  |  |  |  |  |  |  | 
| 873 |  |  |  |  |  |  | This is alpha software and as such, the features and interface are subject to | 
| 874 |  |  |  |  |  |  | change.  So please check the Changes file when upgrading. | 
| 875 |  |  |  |  |  |  |  | 
| 876 |  |  |  |  |  |  |  | 
| 877 |  |  |  |  |  |  | =head1 SEE ALSO | 
| 878 |  |  |  |  |  |  |  | 
| 879 |  |  |  |  |  |  | L, L, perl(1) | 
| 880 |  |  |  |  |  |  |  | 
| 881 |  |  |  |  |  |  |  | 
| 882 |  |  |  |  |  |  | =head1 AUTHOR | 
| 883 |  |  |  |  |  |  |  | 
| 884 |  |  |  |  |  |  | Cees Hek | 
| 885 |  |  |  |  |  |  |  | 
| 886 |  |  |  |  |  |  | =head1 CREDITS | 
| 887 |  |  |  |  |  |  |  | 
| 888 |  |  |  |  |  |  | Thanks to SiteSuite (http://www.sitesuite.com.au) for funding the development | 
| 889 |  |  |  |  |  |  | of this plugin and for releasing it to the world. | 
| 890 |  |  |  |  |  |  |  | 
| 891 |  |  |  |  |  |  |  | 
| 892 |  |  |  |  |  |  | =head1 LICENCE AND COPYRIGHT | 
| 893 |  |  |  |  |  |  |  | 
| 894 |  |  |  |  |  |  | Copyright (c) 2005, SiteSuite. All rights reserved. | 
| 895 |  |  |  |  |  |  |  | 
| 896 |  |  |  |  |  |  | This module is free software; you can redistribute it and/or modify it under | 
| 897 |  |  |  |  |  |  | the same terms as Perl itself. | 
| 898 |  |  |  |  |  |  |  | 
| 899 |  |  |  |  |  |  | =head1 DISCLAIMER OF WARRANTY | 
| 900 |  |  |  |  |  |  |  | 
| 901 |  |  |  |  |  |  | BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE | 
| 902 |  |  |  |  |  |  | SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE | 
| 903 |  |  |  |  |  |  | STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE | 
| 904 |  |  |  |  |  |  | SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, | 
| 905 |  |  |  |  |  |  | INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND | 
| 906 |  |  |  |  |  |  | FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND | 
| 907 |  |  |  |  |  |  | PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, | 
| 908 |  |  |  |  |  |  | YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION. | 
| 909 |  |  |  |  |  |  |  | 
| 910 |  |  |  |  |  |  | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY | 
| 911 |  |  |  |  |  |  | COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE | 
| 912 |  |  |  |  |  |  | SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, | 
| 913 |  |  |  |  |  |  | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING | 
| 914 |  |  |  |  |  |  | OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO | 
| 915 |  |  |  |  |  |  | LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR | 
| 916 |  |  |  |  |  |  | THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), | 
| 917 |  |  |  |  |  |  | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH | 
| 918 |  |  |  |  |  |  | DAMAGES. | 
| 919 |  |  |  |  |  |  |  | 
| 920 |  |  |  |  |  |  | =cut | 
| 921 |  |  |  |  |  |  |  | 
| 922 |  |  |  |  |  |  | 1; |