view release on metacpan or  search on metacpan

Security.pm  view on Meta::CPAN

package CGI::AppBuilder::Security;

# Perl standard modules
use strict;
use warnings;
use Getopt::Std;
use POSIX qw(strftime);
use Carp;
use CGI ':standard';
use CGI::Cookie;
use CGI::AppBuilder;
use CGI::AppBuilder::Message qw(:echo_msg);

our $VERSION = 0.12;
require Exporter;
our @ISA         = qw(Exporter CGI::AppBuilder);
our @EXPORT      = qw();
our @EXPORT_OK   = qw(access_ok get_cookies set_cookies
                   );
our %EXPORT_TAGS = (
    access => [qw(access_ok)],
    all  => [@EXPORT_OK]
);

=head1 NAME

CGI::AppBuilder::Security - Security Procedures

=head1 SYNOPSIS

  use CGI::AppBuilder::Security;

  my $sec = CGI::AppBuilder::Security->new();
  my ($sta, $msg) = $sec->access_ok($ar); 

=head1 DESCRIPTION

This class provides methods for reading and parsing configuration
files. 

=cut

=head2 new (ifn => 'file.cfg', opt => 'hvS:')

This is a inherited method from CGI::AppBuilder. See the same method
in CGI::AppBuilder for more details.

=cut

sub new {
  my ($s, %args) = @_;
  return $s->SUPER::new(%args);
}

=head2 access_ok($ar)

Input variables:

  $ar  - array ref containing the following variables:
  task		: task name required ($t)
  sel_sn1	: select one (DB/server name)
  sel_sn2	: select two (Argument)
  allowed_ip	: allowed ip address for each task
  roles		: roles allowed to access a list of tasks
  svr_allowed	: server allowed for each task
  arg_required	: required argument for each task

Variables used or routines called:

  None

Security.pm  view on Meta::CPAN

    # build user and task list
    my $utk = {};   # hash array for user and task list
    if (exists $ar->{usr_task}) {
      foreach my $u (keys %{$usr_task}) {
        map { my $t = $usr_task->{$u}[$_]; $utk->{$t} = 1; } 
          0..$#{$usr_task->{$u}};
      }
    }
    if (exists $ar->{usr_role}) {
      foreach my $u (keys %{$usr_role}) {		# user
        for my $i (0..$#{$usr_role->{$u}}) {		# role
          my $r = $usr_role->{$u}[$i]; 
          next if ! exists $rol_task->{$r}; 
          map { my $t = $rol_task->{$u}[$_]; $utk->{$t} = 1; } 
            0..$#{$rol_task->{$u}};
        }
      }
    }
    $ok = ( (exists $usr_role->{$usr} || exists $usr_task->{$usr}) &&
            (!exists $utk->{$tsk} || !$utk->{$tsk} ) ) ? 0 : 1;
    return ($ok, "ERR: User $usr is not allowed to run Task $tsk!") if !$ok;

    return ($ok,$msg);
}

# ---------------------------------------------------------------------------------

=head3 get_cookies ($cgi,$ar)

Input variables:

  $cgi - CGI object
  $ar  - Array ref containing all the parameters

Variables used or routines called: 

  disp_param - display parameters

How to use:

  my $q = new CGI;
  my %cfg = (usr=>'jsmith', pwd=>'jojo');
  my @names = $q->param;
  foreach my $k (@names) { $cfg{$k} = $q->param($k) if ! exists $cfg{$k}; }
  $self->get_cookies($q, \%cfg);

Return: ($ck_ar, $ck1, $ck2, $ck3) - hash array reference for cookies 
(${$ck_ar}{$ck}{$ck}) and cookie names.

This method retrieves and parses cookies set by previous process and 
returns them in a hash array reference.

=cut

sub get_cookies {
    my $s = shift;
    my ($q, $ar) = @_;
    
    # retrieve cookies
    # my %cookies = fetch CGI::Cookie;
    my %cookies = CGI::Cookie->fetch;
$s->disp_param(\%cookies);     
    
    my %cks = ();  # parsed cookies
    foreach my $k (sort keys %cookies) {
        foreach my $rec (split /;/, $cookies{$k}) {
            my ($k1, $v1) = split /=/, $rec;
            $cks{$k}{$k1} = $v1;
        }
    }
    $s->disp_param(\%cks) if exists $ar->{v} && $ar->{v};
    wantarray ? %cks : \%cks;       
}


=head3 set_cookies ($cgi,$ar, $cr, $dr)

Input variables:

  $cgi - CGI object
  $ar  - Array ref containing all the parameters
  $cr  - cookie array ref
  $dr  - access array ref

Variables used or routines called: 

  get_cookies - get cookie hash array ref
  get_access  - get access hash array ref

How to use:

  my $q = new CGI;
  my %cfg = (usr=>'jsmith', pwd=>'jojo');
  my @names = $q->param;
  foreach my $k (@names) { $cfg{$k} = $q->param($k) if ! exists $cfg{$k}; }
  $self->get_cookies($q, \%cfg);

Return: 1 or 0 to indicates whether setting cookies is sucessfull.

This method retrieves and parses cookies set by previous process and 
returns them in a hash array reference.

=cut

sub set_cookies {
    my $s = shift;
    my ($q, $ar, $cr, $dr) = @_;
    
    # $cr = $s->get_cookies($q, $ar) if ! $cr;
    # $dr = $s->get_access($q, $ar)  if ! $dr;
    $cr = $s->get_cookies($q, $ar);
    # $s->echo_msg($cr, 0);
    
    my $dn = $ENV{HTTP_HOST};
    my $vs = 'UID,PWD,SID';
    my $kv = {}; 
    my $ck  = [];
    foreach my $k (split ',',$vs) {
      my $k1 = "ck$k";
      my $k2 = "user_" . lc($k);
      my $v  = (exists $ar->{$k2}) ? $ar->{$k2} : '';
      if ($k =~ /^timeout/i && $v) {
        # convert YYYYMMDD.HH24MISS to perl time
        # $time = timelocal($sec,$min,$hour,$mday,$mon,$year);
        my $yr = substr($v,1,4) - 1900;
        my $mn = substr($v,5,2);
        my $dd = substr($v,7,2);
        my $hh = substr($v,10,2);
        my $mm = substr($v,12,2);
        my $ss = substr($v,14,2);
        $v = timelocal($ss,$mm,$hh,$dd,$mn,$yr); 
      } 
      $v  = $cr->{$k1} 	if !$v && exists $cr->{$k1}; 
      $kv->{$k1} = $v;          
      push @$ck, $q->cookie(-name=>$k1,-value=>$v,-domain=>$dn, 
        -expires=>'+3M');
    }
    $ar->{_cookie} = $ck;
    # print header(-cookie=>$ck); 
    # for my $i (0..$#$ck) { my $c = $ck->[$i]; print "Set-Cookie: $c\n";  } 
    # print "Content-Type: text/html\n\n"; 

    # $s->echo_msg($kv, 3); 
    # $s->echo_msg($ck, 0);
    # my $c2 = $s->get_cookies($q, $ar); 
    # $s->echo_msg($c2, 0);
    return 0 if !$kv->{ckUID} || !$kv->{ckPWD};
    return 1;       
}

1;

=head1 HISTORY

=over 4

=item * Version 0.10

This version ported from ora_jobs.pl on 9/17/2009.

=item * Version 0.20

=cut

=head1 SEE ALSO (some of docs that I check often)

Oracle::Loader, Oracle::Trigger, CGI::AppBuilder, File::Xcopy,
CGI::AppBuilder::Message

=head1 AUTHOR

Copyright (c) 2009 Hanming Tu.  All rights reserved.

This package is free software and is provided "as is" without express
or implied warranty.  It may be used, redistributed and/or modified
under the terms of the Perl Artistic License (see
http://www.perl.com/perl/misc/Artistic.html)

=cut