home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / DBILogin.pm < prev    next >
Encoding:
Perl POD Document  |  2002-06-13  |  7.4 KB  |  258 lines
  1. # $Id: DBILogin.pm,v 1.2 2001/02/21 19:14:47 jdg117 Exp $
  2. package Apache::DBILogin;
  3. use strict;
  4. use Apache();
  5. use Apache::Constants qw(OK SERVER_ERROR AUTH_REQUIRED FORBIDDEN);
  6. use DBI;
  7. use vars qw($VERSION);
  8.  
  9. $VERSION = '2.0';
  10. my(%Config) = (
  11.     'Auth_DBI_data_source' => '',
  12.     'Auth_DBI_authz_command' => '',
  13.     'DBILogin_Oracle_authz_command' => '',
  14. );
  15. my $prefix = "Apache::DBILogin";
  16.  
  17. sub authen {
  18.     my $r = shift @_;
  19.     return OK unless $r->is_initial_req;
  20.  
  21.     my($key,$val);
  22.     my $attr = {};
  23.     while(($key,$val) = each %Config) {
  24.         $val = $r->dir_config($key) || $val;
  25.         $key =~ s/^Auth_DBI_//;
  26.         $attr->{$key} = $val;
  27.     }
  28.     
  29.     return test_authen($r, $attr);
  30. }
  31.  
  32. sub test_authen {
  33.     my($r, $attr) = @_;
  34.  
  35.     my ($res, $sent_pwd) = $r->get_basic_auth_pw;
  36.     return $res if ( $res ); #decline if not Basic
  37.  
  38.     my $user = $r->connection->user;
  39.  
  40.     unless ( $attr->{data_source} ) {
  41.         $r->log_reason("$prefix is missing the source parameter for database connect", $r->uri);
  42.         return SERVER_ERROR;
  43.     }
  44.  
  45.     my $dbh = DBI->connect($attr->{data_source}, $user, $sent_pwd, { AutoCommit=>0, RaiseError=>0 });
  46.     unless( defined $dbh ) {
  47.         $r->log_reason("user $user: $DBI::errstr", $r->uri);
  48.         $r->note_basic_auth_failure;
  49.         return AUTH_REQUIRED;
  50.     }
  51.  
  52.     # to be removed in next version
  53.     if ( $attr->{authz_command} ) {
  54.         unless( defined ($dbh->do($attr->{authz_command})) ) {
  55.             $r->log_reason("user $user: $DBI::errstr", $r->uri);
  56.             $r->note_basic_auth_failure;
  57.             return AUTH_REQUIRED;
  58.         }
  59.     }
  60.            
  61.     $dbh->disconnect;
  62.     $r->header_in('Modperl_DBILogin_Password',$sent_pwd);
  63.     $r->header_in('Modperl_DBILogin_data_source',$attr->{data_source});
  64.     return OK;
  65. }
  66.  
  67. sub authz {
  68.     my $r = shift @_;
  69.     return OK unless $r->is_initial_req;
  70.  
  71.     my $user = $r->connection->user;
  72.  
  73.     my($key,$val);
  74.     my $attr = {};
  75.     while(($key,$val) = each %Config) {
  76.         $val = $r->dir_config($key) || $val;
  77.         $key =~ s/^Auth_DBI_//;
  78.         $attr->{$key} = $val;
  79.     }
  80.     
  81.     return test_authz($r, $attr);
  82. }
  83.  
  84. sub test_authz {
  85.     my($r, $attr) = @_;
  86.  
  87.     my ($res, $sent_pwd) = $r->get_basic_auth_pw;
  88.     return $res if ( $res ); #decline if not Basic
  89.  
  90.     my $user = $r->connection->user;
  91.  
  92.     unless ( $attr->{data_source} ) {
  93.         $r->log_reason("$prefix is missing the source parameter for database connect", $r->uri);
  94.         return SERVER_ERROR;
  95.     }
  96.  
  97.     my $dbh = DBI->connect($attr->{data_source}, $user, $sent_pwd, {AutoCommit=>0, RaiseError=>0});
  98.     unless( defined $dbh ) {
  99.         $r->log_reason("user $user: $DBI::errstr", $r->uri);
  100.         return SERVER_ERROR;
  101.     }
  102.  
  103.     my $authz_result = FORBIDDEN;
  104.     my $sth;
  105.     foreach my $requirement ( @{$r->requires} ) {
  106.         my $require = $requirement->{requirement};
  107.         if ( $require eq "valid-user" ) {
  108.             $authz_result = OK;
  109.         } elsif ( $require =~ s/^user\s+// ) { 
  110.                 foreach my $valid_user (split /\s+/, $require) {
  111.                     if ( $user eq $valid_user ) {
  112.                         $authz_result = OK;
  113.                         last;
  114.                     }
  115.                 }
  116.                 if ( $authz_result != OK ) {
  117.                     my $explaination = <<END;
  118. <HTML>
  119. <HEAD><TITLE>Unauthorized</TITLE></HEAD>
  120. <BODY>
  121. <H1>Unauthorized</H1>
  122. User must be one of these required users: $require
  123. </BODY>
  124. </HTML>
  125. END
  126.                     $r->custom_response(FORBIDDEN, $explaination);
  127.                     $r->log_reason("user $user: not authorized", $r->uri);
  128.                 }
  129.             } elsif ( $require =~ s/^group\s+// ) {
  130.                     foreach my $group (split /\s+/, $require) {
  131.                         $authz_result = is_member($r, $dbh, $group);
  132.                         last if ( $authz_result == OK );
  133.                         if ( $authz_result == SERVER_ERROR ) {
  134.                             $r->log_reason("user $user: $@", $r->uri);
  135.                             return SERVER_ERROR;
  136.                         }
  137.                     }
  138.                     if ( $authz_result == FORBIDDEN ) {
  139.                         my $explaination = <<END;
  140. <HTML>
  141. <HEAD><TITLE>Unauthorized</TITLE></HEAD>
  142. <BODY>
  143. <H1>Unauthorized</H1>
  144. User must be member of one of these required groups: $require
  145. </BODY>
  146. </HTML>
  147. END
  148.                         $r->custom_response(FORBIDDEN, $explaination);
  149.                         $r->log_reason("user $user: not authorized", $r->uri);
  150.                     }
  151.                 }
  152.     }
  153.  
  154.     $dbh->disconnect;
  155.     return $authz_result;
  156. }
  157.  
  158. 1;
  159.  
  160. __END__
  161.  
  162. =head1 NAME
  163.  
  164. Apache::DBILogin - authenticates and authorizes via a DBI connection
  165.  
  166. =head1 SYNOPSIS
  167.  
  168.  #in .htaccess
  169.  AuthName MyAuth
  170.  AuthType Basic
  171.  PerlAuthenHandler Apache::DBILogin::authen
  172.  PerlSetVar Auth_DBI_data_source dbi:Oracle:SQLNetAlias
  173.  PerlAuthzHandler Apache::DBILogin::authz
  174.  
  175.  allow from all
  176.  require group connect resource dba
  177.  satisfy all
  178.  
  179.  #in startup.pl
  180.  package Apache::DBILogin;
  181.  
  182.  # is_member function for authz handler
  183.  #  expects a request object, database handle, and the group you which to test
  184.  #  returns a valid response code
  185.  sub is_member {
  186.      my ($r, $dbh, $group) = @_;
  187.  
  188.      my $sth;
  189.      eval {
  190.          # no, Oracle doesn't support binding in SET ROLE statement
  191.          $sth = $dbh->prepare("SET ROLE $group") or die $DBI::errstr;
  192.      };
  193.      return SERVER_ERROR if ( $@ );
  194.  
  195.      return ( defined $sth->execute() ) ? OK : FORBIDDEN;
  196.  }
  197.  
  198. =head1 DESCRIPTION
  199.  
  200. Apache::DBILogin allows authentication and authorization against a
  201. multi-user database.
  202.  
  203. It is intended to facilitate web-based transactions against a database server
  204. as a particular database user. If you wish authenticate against a passwd
  205. table instead, please see Edmund Mergl's Apache::AuthDBI module.
  206.  
  207. Group authorization is handled by your Apache::DBILogin::is_member()
  208. function which you must define if you enable the authz handler.
  209.  
  210. The above example uses Oracle roles to assign group membership. A role is a
  211. set of database privileges which can be assigned to users. Unfortunately,
  212. roles are vendor specific. Under Oracle you can test membership with
  213. "SET ROLE role_name" statement. You could also query the data dictionary,
  214. DBA_ROLE_PRIVS, but under Oracle that requires explicit privilege.
  215. Documentation patches for other databases are welcome.
  216.  
  217. =head1 ENVIRONMENT
  218.  
  219. Applications may access the clear text password as well as the data_source
  220. via the environment variables B<HTTP_MODPERL_DBILOGIN_PASSWORD> and
  221. B<HTTP_MODPERL_DBILOGIN_DATA_SOURCE>.
  222.  
  223.  #!/usr/bin/perl -wT
  224.  
  225.  use strict;
  226.  use CGI;
  227.  use DBI;
  228.  my $name = $ENV{REMOTE_USER};
  229.  my $password = $ENV{HTTP_DBILOGIN_PASSWORD};
  230.  my $data_source = $ENV{HTTP_DBILOGIN_DATA_SOURCE};
  231.  my $dbh = DBI->connect($data_source, $name, $password)
  232.      or die "$DBI::err: $DBI::errstr\n";
  233.  ...
  234.  
  235. =head1 SECURITY
  236.  
  237. The database user's clear text passwd is made available in the
  238. server's environment. Do you trust your developers?
  239.  
  240. =head1 BUGS
  241.  
  242. Probably lots, I'm not the best programmer in the world.
  243.  
  244. =head1 NOTES
  245.  
  246. Feel free to email me with comments, suggestions, flames. Its the
  247. only way I'll become a better programmer.
  248.  
  249. =head1 SEE ALSO
  250.  
  251. mod_perl(1), Apache::DBI(3), and Apache::AuthDBI(3)
  252.  
  253. =head1 AUTHOR
  254.  
  255. John Groenveld E<lt>groenveld@acm.orgE<gt>
  256.  
  257. =cut
  258.