[309] | 1 | package LATMOS::Accounts::Acls; |
---|
| 2 | |
---|
| 3 | use strict; |
---|
| 4 | use warnings; |
---|
| 5 | use LATMOS::Accounts::Log; |
---|
[1048] | 6 | use LATMOS::Accounts::Acls::Acl; |
---|
[309] | 7 | |
---|
| 8 | our $VERSION = (q$Rev: 330 $ =~ /^Rev: (\d+) /)[0]; |
---|
| 9 | |
---|
[1023] | 10 | =head1 NAME |
---|
| 11 | |
---|
| 12 | LATMOS::Accounts::Acls - Acl support in L<LATMOS::Accounts> |
---|
| 13 | |
---|
| 14 | =head1 FUNCTIONS |
---|
| 15 | |
---|
| 16 | =cut |
---|
| 17 | |
---|
[1048] | 18 | =head2 new ($file) |
---|
[1023] | 19 | |
---|
| 20 | Instanciate Acls from C<$file> |
---|
| 21 | |
---|
| 22 | =cut |
---|
| 23 | |
---|
[309] | 24 | sub new { |
---|
| 25 | my ($class, $file) = @_; |
---|
| 26 | my $acls = bless( |
---|
| 27 | { |
---|
| 28 | _acls => [] |
---|
| 29 | }, $class |
---|
| 30 | ); |
---|
| 31 | if ($file) { |
---|
| 32 | $acls->read_acl_file($file) or return; |
---|
| 33 | } |
---|
[2259] | 34 | |
---|
| 35 | # Default ACLS: |
---|
| 36 | $acls->add( '*.log', [ '$uid: read', '*: deny' ] ); |
---|
| 37 | $acls->add( |
---|
| 38 | 'user.{userPasswd,userPassword,encryptedPassword}', |
---|
| 39 | [ '$uid: write', '*: deny' ], |
---|
| 40 | ); |
---|
[309] | 41 | $acls |
---|
| 42 | } |
---|
| 43 | |
---|
[310] | 44 | =head1 ACL FILE FORMAT |
---|
| 45 | |
---|
| 46 | OBJ_TYPE.ATTRIBUTE |
---|
| 47 | USER: read,write |
---|
| 48 | USER2: read |
---|
| 49 | |
---|
| 50 | =over 4 |
---|
| 51 | |
---|
| 52 | =item OBJ_TYPE is the type the object, '*' match all |
---|
| 53 | |
---|
| 54 | =item ATTRIBUTE is either an attribute, either an comma separate attribute |
---|
[421] | 55 | enclose into bracket, either a '*' to match any attribute. |
---|
[310] | 56 | |
---|
[481] | 57 | Special keyword C<@CREATE> and C<@DELETE> can be used to allow or deny object |
---|
[488] | 58 | creation and deletion. In this case read permission and USER in form C<$...> for |
---|
| 59 | C<@CREATE> have no effect (see below). C<*> do not include C<@CREATE> and |
---|
| 60 | C<@DELETE> action. |
---|
[421] | 61 | |
---|
[310] | 62 | =item USER can be |
---|
| 63 | |
---|
| 64 | =over 4 |
---|
| 65 | |
---|
| 66 | =item a username |
---|
| 67 | |
---|
| 68 | =item group, prefixed by a '%' |
---|
| 69 | |
---|
| 70 | =item an attribute of the accessed object which should contains the username, |
---|
| 71 | prefixed by '$' |
---|
| 72 | |
---|
[321] | 73 | =item C<*> to math any user |
---|
| 74 | |
---|
| 75 | =item @authenticated or @anonymous for any authenticated user and non |
---|
| 76 | authenticated user ('*' include both) |
---|
| 77 | |
---|
[310] | 78 | =back |
---|
| 79 | |
---|
| 80 | =item Permission are read and or write, or deny. |
---|
| 81 | |
---|
| 82 | =back |
---|
| 83 | |
---|
| 84 | ACL are applied in the order they appear in the file. |
---|
| 85 | |
---|
| 86 | =cut |
---|
| 87 | |
---|
[1023] | 88 | =head2 read_acl_file ($file) |
---|
| 89 | |
---|
| 90 | Load acls from file C<$file>. |
---|
| 91 | |
---|
| 92 | =cut |
---|
| 93 | |
---|
[309] | 94 | sub read_acl_file { |
---|
| 95 | my ($self, $file) = @_; |
---|
| 96 | |
---|
| 97 | my $acl; |
---|
| 98 | my $line_nb = 0; |
---|
[314] | 99 | my $prevline = ""; |
---|
[309] | 100 | if (open(my $handle, '<', $file)) { |
---|
| 101 | while(my $realline = <$handle>) { |
---|
| 102 | $line_nb++; |
---|
[314] | 103 | chomp($realline); |
---|
| 104 | if ($realline =~ /\\$/) { |
---|
| 105 | # continuation line |
---|
| 106 | $prevline .= $realline; |
---|
| 107 | $prevline =~ s/\s*\\$//; |
---|
| 108 | next; |
---|
| 109 | } |
---|
| 110 | my $line = $prevline . $realline; # keep track to report malformed file |
---|
| 111 | $prevline = ""; |
---|
[310] | 112 | $line =~ s/\s*#.*//; |
---|
[314] | 113 | if ($line =~ /^(\S.*)/) { |
---|
[309] | 114 | if ($acl) { |
---|
| 115 | push(@{$self->{_acls}}, $acl); |
---|
| 116 | } |
---|
[1048] | 117 | $acl = LATMOS::Accounts::Acls::Acl->new($1) or do { |
---|
[309] | 118 | la_log(LA_ERR, "Error in %s at line %d", $file, |
---|
| 119 | $line_nb); |
---|
| 120 | return; |
---|
| 121 | }; |
---|
[314] | 122 | } elsif ($line =~ /^\s+(\S.*)/) { |
---|
[309] | 123 | if ($acl) { |
---|
| 124 | $acl->add_perm($line) or do { |
---|
| 125 | la_log(LA_ERR, "Error in %s at line %d", $file, |
---|
| 126 | $line_nb); |
---|
| 127 | return; |
---|
| 128 | }; |
---|
| 129 | } else { |
---|
| 130 | # err no acl |
---|
| 131 | return; |
---|
| 132 | } |
---|
| 133 | } elsif ($line =~ /^\s*$/) { |
---|
| 134 | # just empty line |
---|
| 135 | } else { |
---|
| 136 | } |
---|
| 137 | } |
---|
| 138 | if ($acl) { |
---|
| 139 | push(@{$self->{_acls}}, $acl); |
---|
| 140 | } |
---|
| 141 | } else { |
---|
| 142 | la_log(LA_ERR, "Cannot open acl file %s", $file); |
---|
[323] | 143 | return; |
---|
[309] | 144 | } |
---|
| 145 | 1; |
---|
| 146 | } |
---|
| 147 | |
---|
[1023] | 148 | =head2 add ($obj_dot_attr, $list) |
---|
| 149 | |
---|
| 150 | A new acl for C<$obj_dot_attr> (in form C<object.attribute>) with C<$list> |
---|
| 151 | permissions. |
---|
| 152 | |
---|
| 153 | =cut |
---|
| 154 | |
---|
[309] | 155 | sub add { |
---|
| 156 | my ($self, $obj, $list) = @_; |
---|
[1048] | 157 | my $acl = LATMOS::Accounts::Acls::Acl->new( |
---|
[309] | 158 | $obj, $list) or return; |
---|
| 159 | push(@{$self->{_acls}}, $acl); |
---|
| 160 | return 1; |
---|
| 161 | } |
---|
| 162 | |
---|
[1023] | 163 | =head2 check ($obj, $attr, $perm, $who, $groups) |
---|
| 164 | |
---|
| 165 | Return true is this acl apply to C<$obj>/C<$attr> for C<$perm> by user |
---|
| 166 | C<$who> in groups C<$groups>. |
---|
| 167 | |
---|
| 168 | =cut |
---|
| 169 | |
---|
[310] | 170 | sub check { |
---|
| 171 | my ($self, $obj, $attr, $perm, $who, $groups) = @_; |
---|
[481] | 172 | # Asking 'r' perm over create or delete has no sense: |
---|
| 173 | $attr =~ /^@(CREATE|DELETE)$/ && $perm eq 'r' and return; |
---|
| 174 | |
---|
[310] | 175 | foreach my $acl (@{$self->{_acls}}) { |
---|
| 176 | my $res = $acl->match($obj, $attr, $perm, $who, $groups); |
---|
| 177 | defined($res) and return $res; |
---|
| 178 | } |
---|
| 179 | return 0; |
---|
| 180 | } |
---|
| 181 | |
---|
[1023] | 182 | =head2 dump |
---|
| 183 | |
---|
[1048] | 184 | Return currently load acl as text |
---|
[1023] | 185 | |
---|
| 186 | =cut |
---|
| 187 | |
---|
[315] | 188 | sub dump { |
---|
| 189 | my ($self) = @_; |
---|
[1048] | 190 | foreach my $acl (@{$self->{_acls}}) { |
---|
| 191 | print $acl->dump, "\n"; |
---|
[315] | 192 | } |
---|
| 193 | } |
---|
| 194 | |
---|
[309] | 195 | 1; |
---|
| 196 | |
---|
| 197 | __END__ |
---|
[1023] | 198 | |
---|
| 199 | =head1 SEE ALSO |
---|
| 200 | |
---|
[1048] | 201 | L<LATMOS::Accounts::Acls::Acl> |
---|
| 202 | |
---|
[1023] | 203 | =head1 AUTHOR |
---|
| 204 | |
---|
| 205 | Thauvin Olivier, E<lt>olivier.thauvin@latmos.ipsl.frE<gt> |
---|
| 206 | |
---|
| 207 | =head1 COPYRIGHT AND LICENSE |
---|
| 208 | |
---|
| 209 | Copyright (C) 2009, 2010, 2011, 2012 by Thauvin Olivier |
---|
| 210 | |
---|
| 211 | This library is free software; you can redistribute it and/or modify |
---|
| 212 | it under the same terms as Perl itself, either Perl version 5.10.0 or, |
---|
| 213 | at your option, any later version of Perl 5 you may have available. |
---|
| 214 | |
---|
| 215 | =cut |
---|