1 | use strict; |
---|
2 | use warnings; |
---|
3 | use Test::More tests => 14; |
---|
4 | |
---|
5 | use_ok('LATMOS::Accounts::Acls'); |
---|
6 | |
---|
7 | { |
---|
8 | ok(my $acl = LATMOS::Accounts::Acls::acl->new('user.uid', [ 'user1: read' ]), |
---|
9 | "can create single acl"); |
---|
10 | is($acl->match(fakeobject->new('user', 'user1'), 'uid', 'r', 'user1'), 1, "acl match"); |
---|
11 | is($acl->match(fakeobject->new('user', 'user2'), 'uid', 'w', 'user1') || 0, 0, "acl match"); |
---|
12 | } |
---|
13 | |
---|
14 | { |
---|
15 | ok(my $acls = LATMOS::Accounts::Acls->new, "Can create new acls objects"); |
---|
16 | ok($acls->add('user.uid', [ 'user1: read' ]), "Can add new acl"); |
---|
17 | } |
---|
18 | |
---|
19 | { |
---|
20 | ok(my $acls = LATMOS::Accounts::Acls->new('testdata/acls1'), |
---|
21 | "Can create new acls objects from file"); |
---|
22 | # now testing... |
---|
23 | is( |
---|
24 | $acls->check(fakeobject->new('user', 'user1'), 'uid', 'r', 'user1'), |
---|
25 | 1, "user can read uid"); |
---|
26 | is( |
---|
27 | $acls->check(fakeobject->new('user', 'user1'), 'userPassword', 'r', 'user1'), |
---|
28 | 0, "user cannot read userPassword"); |
---|
29 | is( |
---|
30 | $acls->check(fakeobject->new('user', 'user1'), 'uid', 'w', 'user1'), |
---|
31 | 0, "user cannot write uid"); |
---|
32 | is( |
---|
33 | $acls->check(fakeobject->new('user', 'user1'), 'givenName', 'w', 'user1'), |
---|
34 | 1, "user can write givenName"); |
---|
35 | is( |
---|
36 | $acls->check(fakeobject->new('user', 'user1'), 'uid', 'w', |
---|
37 | 'user1', [ 'admin' ]), 0, "user cannot write user attribute"); |
---|
38 | is( |
---|
39 | $acls->check(fakeobject->new('group', 'group1'), 'uid', 'w', |
---|
40 | 'user1', [ 'admin' ]), 1, "user can write group attribute"); |
---|
41 | is( |
---|
42 | $acls->check('user', 'CREATE', 'w', 'user1', [ 'admin' ]), 1, |
---|
43 | "user can create a new user"); |
---|
44 | } |
---|
45 | |
---|
46 | |
---|
47 | # A fake object to test only ACLs |
---|
48 | package fakeobject; |
---|
49 | |
---|
50 | sub new { |
---|
51 | my ($class, $type, $id) = @_; |
---|
52 | bless({type => $type, id => $id}, $class); |
---|
53 | } |
---|
54 | |
---|
55 | sub type { |
---|
56 | $_[0]->{type} |
---|
57 | } |
---|
58 | |
---|
59 | sub id { |
---|
60 | $_[0]->{id} |
---|
61 | } |
---|
62 | |
---|
63 | sub _get_c_field { |
---|
64 | $_[0]->{id} |
---|
65 | } |
---|