lib/Apache2/AuthzCaps.pm

   1 package Apache2::AuthzCaps 0.001;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6 use subs qw/OK DECLINED/;
   7 no if $] >= 5.017011, warnings => 'experimental::smartmatch';
   8
   9 use if $ENV{MOD_PERL}, 'Apache2::Access';
  10 use if $ENV{MOD_PERL}, 'Apache2::Const' => qw/OK DECLINED/;
  11 use if $ENV{MOD_PERL}, 'Apache2::RequestRec';
  12 use YAML::Any qw/LoadFile DumpFile/;
  13
  14 use parent qw/Exporter/;
  15
  16 our @EXPORT_OK = qw/setcap hascaps/;
  17
  18 ##################################################
  19
  20 our $rootdir;
  21
  22 sub setcap{
  23   my ($user, $cap, $value) = @_;
  24   my $config = eval { LoadFile "$rootdir/$user.yml" } // {};
  25   $config->{caps}//={};
  26   my $caps=$config->{caps};
  27
  28   delete $caps->{$cap} unless $value;
  29   $caps->{$cap} = 1 if $value;
  30   DumpFile "$rootdir/$user.yml", $config
  31 }
  32
  33 sub hascaps{
  34   my ($user, @caps) = @_;
  35   my $config = LoadFile "$rootdir/$user.yml";
  36   my $caps = $config->{caps};
  37   for (@caps) {
  38         return 0 unless $caps->{$_}
  39   }
  40   1
  41 }
  42
  43 sub handler{
  44   my $r=shift;
  45   my $user = $r->user;
  46   local $rootdir = $r->dir_config('AuthzCapsRootdir');
  47
  48   if ($user) {
  49   LOOP: for my $requirement (map { $_->{requirement} } @{$r->requires}) {
  50           my ($command, @args) = split ' ', $requirement;
  51
  52           given ($command){
  53                 when('cap'){
  54                   return OK if hascaps $user, @args
  55                 }
  56
  57           }
  58         }
  59   }
  60
  61   DECLINED
  62 }
  63
  64 1;
  65 __END__
  66
  67 =head1 NAME
  68
  69 Apache2::AuthzCaps - mod_perl2 capability authorization
  70
  71 =head1 SYNOPSIS
  72
  73   use Apache2::AuthzCaps qw/setcap hascaps/;
  74   $Apache2::AuthzCaps::rootdir = "/path/to/user/directory"
  75   setcap marius => deleteusers => 1; # Grant marius the deleteusers capability
  76   setcap marius => createusers => 0;
  77   hascaps marius => qw/deleteusers/; # returns 1, since marius can delete users
  78   hascaps marius => qw/deleteusers createusers/; # returns 0, since marius can delete users but cannot create users
  79
  80   # In Apache2 config
  81   <Location /protected>
  82     # Insert authentication here
  83     PerlAuthzHandler Apache2::AuthzCaps
  84     PerlSetVar AuthzCapsRootdir /path/to/user/directory
  85     Require cap staff important
  86     Require cap admin
  87   </Location>
  88   # This will:
  89   # 1) Let important staff members access /protected
  90   # 2) Let admins access /protected
  91   # 3) Not let anyone else (such as an important non-staff member or an non-important staff member) access /protected
  92
  93 =head1 DESCRIPTION
  94
  95 Apache2::AuthzCaps is a perl module which provides simple Apache2 capability-based authorization. It contains a PerlAuthzHandler and some utility functions.
  96
  97 The user data is stored in YAML files in a user-set directory. Set this directory using:
  98
  99   $Apache2::AuthzCaps::rootdir = "/path/to/directory"; # From perl
 100   PerlSetVar AuthzCapsRootdir /path/to/directory # From Apache2 config
 101
 102 =head1 FUNCTIONS
 103
 104 =over
 105
 106 =item B<setcap>(I<$username>, I<$capability>, I<$value>)
 107
 108 If I<$value> is true, grants I<$username> the I<$capability> capability. Otherwise denies I<$username> that capability.
 109
 110 =item B<hascaps>(I<$username>, I<$cap>, ...)
 111
 112 Returns true if and only of I<$username> has ALL of the listed capabilities. Dies if I<$username> does not exist.
 113
 114 =item B<handler>
 115
 116 The PerlAuthzHandler for use in apache2.
 117
 118 =back
 119
 120 =head1 AUTHOR
 121
 122 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 123
 124 =head1 COPYRIGHT AND LICENSE
 125
 126 Copyright (C) 2013 by Marius Gavrilescu
 127
 128 This library is free software; you can redistribute it and/or modify
 129 it under the same terms as Perl itself, either Perl version 5.14.2 or,
 130 at your option, any later version of Perl 5 you may have available.
 131
 132
 133 =cut