File Coverage

File:lib/OpenAPI/Handler/Role.pm
Coverage:78.4%

linestmtbrancondsubpodtimecode
1package OpenAPI;
2
3#use Smart::Comments;
4
22
22
22
22
197
68
201
use strict;
5
22
22
22
22
239
75
170
use warnings;
6
7
22
22
22
22
509
72
181
use vars qw($Dumper);
8
9sub has_role {
10
676
676
0
4476
    my ($self, $role) = @_;
11
676
50
4412
    _IDENT($role) or
12        die "Bad role name: ", $Dumper->($role), "\n";
13
676
7017
    my $select = SQL::Select->new('count(*)')
14        ->from('_roles')
15        ->where(name => Q($role))
16        ->limit(1);
17
676
1906
    return $self->select("$select")->[0][0];
18}
19
20sub DELETE_role {
21
5
5
0
42
    my ($self, $bits) = @_;
22
5
49
    my $role = $bits->[1];
23
5
100
44
    if ($role eq '~') {
24
1
7
        return $self->DELETE_role_list;
25    }
26
4
100
100
78
    if ($role eq 'Admin' or $role eq 'Public') {
27
2
9
        die "Role \"$role\" reserved.\n";
28    }
29
2
50
16
    if (!$self->has_role($role)) {
30
0
0
        die "Role \"$role\" not found.\n";
31    }
32
2
117
    my $sql = "delete from _access_rules where role = ".Q($role).";\n".
33        "delete from _roles where name = ".Q($role);
34
2
50
23
    return { success => $self->do($sql) >= 0 ? 1 : 0 };
35}
36
37sub DELETE_access_rule {
38
2
2
0
16
    my ($self, $bits) = @_;
39
2
13
    my $role = $bits->[1];
40
2
12
    my $col = $bits->[2];
41
2
10
    my $value = $bits->[3];
42
2
50
14
    if (!$self->has_role($role)) {
43
0
0
        die "Role \"$role\" not found.\n";
44    }
45
2
50
40
125
    if ($col ne '~' and $col ne 'method' and $col ne 'url' and $col ne 'id') {
46
0
0
        die "Unknown access rule field: $col\n";
47    }
48
2
50
15
    if ($role eq 'Admin') {
49
0
0
        die "Role \"Admin\" is read only.\n";
50    }
51
2
6
    my $sql;
52
2
100
50
19
    if ($value eq '~') {
53
1
8
        $sql = "delete from _access_rules where role = '$role';";
54    } elsif ($col eq '~') {
55
0
0
        my $quoted = Q($value);
56
0
0
        $sql = "delete from _access_rules where role = '$role' and (id::text = $quoted or method = $quoted or url = $quoted);";
57    } else {
58
1
10
        my $quoted = Q($value);
59
1
18
        $sql = "delete from _access_rules where role = '$role' and $col = $quoted;";
60    }
61    ### DELETE access rules: $sql
62
2
18
    my $res = $self->do($sql);
63
2
50
38
    return { success => $res >= 0 ? 1 : 0 };
64}
65
66sub GET_access_rule {
67
21
21
0
167
    my ($self, $bits) = @_;
68
21
129
    my $role = $bits->[1];
69
21
124
    my $col = $bits->[2];
70
21
113
    my $value = $bits->[3];
71    ### $bits
72
21
50
151
    if (!$self->has_role($role)) {
73
0
0
        die "Role \"$role\" not found.\n";
74    }
75
21
50
60
1185
    if ($col ne '~' and $col ne 'method' and $col ne 'url' and $col ne 'id') {
76
0
0
        die "Unknown access rule field: $col\n";
77    }
78
79
21
76
    my $sql;
80
21
100
151
    if ($value eq '~') {
81
14
103
        $sql = "select id,method,url from _access_rules where role = '$role';";
82    } else {
83
7
100
93
        my $op = $self->{_cgi}->url_param('op') || 'eq';
84
7
53
        $op = $OpMap{$op};
85
7
100
51
        if ($op eq 'like') {
86
2
19
            $value = "%$value%";
87        }
88
7
49
        my $quoted = Q($value);
89
90
7
100
58
        if ($col eq '~') {
91
3
72
            $sql = "select id,method,url from _access_rules where role = '$role' and ( id::text $op $quoted or method $op $quoted or url $op $quoted);";
92        } else {
93
4
62
            $sql = "select id,method,url from _access_rules where role = '$role' and $col $op $quoted;";
94        }
95    }
96    ### $sql
97
21
259
    my $res = $self->select($sql, { use_hash => 1 });
98
21
50
368
    $res ||= [];
99
21
191
    return $res;
100}
101
102sub PUT_access_rule {
103
4
4
0
33
    my ($self, $bits) = @_;
104
4
25
    my $role = $bits->[1];
105
4
25
    my $col = $bits->[2];
106
4
23
    my $value = $bits->[3];
107    ### $bits
108
4
50
30
    if (!$self->has_role($role)) {
109
0
0
        die "Role \"$role\" not found.\n";
110    }
111
4
50
202
    if ($role eq 'Admin') {
112
0
0
        die "Role \"Admin\" is read only.\n";
113    }
114
4
50
40
111
    if ($col ne '~' and $col ne 'method' and $col ne 'url' and $col ne 'id') {
115
0
0
        die "Unknown access rule field: $col\n";
116    }
117
118
4
45
    my $update = SQL::Update->new('_access_rules');
119
4
28
    my $data = $self->{_req_data};
120
4
50
34
    _HASH($data) or die "Only non-empty HASH expected.\n";
121
4
175
    while (my ($key, $val) = each %$data) {
122
5
27
        my $col = $key;
123
5
100
34
        if (lc($col) eq 'id') {
124
1
4
            die "Column \"id\" reserved.\n";
125        }
126
4
30
        $update->set($col => Q($val));
127    }
128
129
3
50
23
    if ($value eq '~') {
130
0
0
        $update->where(role => Q($role));
131    } else {
132
3
50
30
        my $op = $self->{_cgi}->url_param('op') || 'eq';
133
3
22
        $op = $OpMap{$op};
134
3
50
20
        if ($op eq 'like') {
135
0
0
            $value = "%$value%";
136        }
137
3
16
        my $quoted = Q($value);
138
139
3
50
26
        if ($col eq '~') {
140
0
0
            $update->where(
141                'role', '=', Q($role),
142                "(id::text $op $quoted or method $op $quoted or url $op $quoted)"
143            );
144
145        } else {
146
3
21
            $update->where(role => Q($role))
147                   ->where($col => $op => $quoted);
148        }
149    }
150    ### Put rule SQL: "$update"
151
3
8
    my $res = $self->do("$update");
152
3
50
13
    return { success => $res >= 0 ? 1 : 0 };
153
154}
155
156sub POST_access_rule {
157
8
8
0
58
    my ($self, $bits) = @_;
158
8
48
    my $role = $bits->[1];
159
8
40
    my $col = $bits->[2];
160
8
40
    my $value = $bits->[3];
161
8
50
53
    if (!$self->has_role($role)) {
162
0
0
        die "Role \"$role\" not found.\n";
163    }
164
8
319
    my $rows_affected = 0;
165
8
39
    my ($success, $last_insert_id);
166
8
53
    my $data = $self->{_req_data};
167
8
100
50
62
    if (_HASH($data)) {
168
7
233
        $rows_affected = $self->insert_rule($role, $data, 1);
169
6
50
138
        $success = $rows_affected >= 1 ? 1 : 0;
170    } elsif (_ARRAY($data)) {
171
1
4
        my $i = 1;
172
1
7
        for my $elem (@$data) {
173            _HASH($elem) or
174                die "Access rule is not of hash: ", $Dumper->($elem), "\n";
175            $rows_affected += $self->insert_rule($role, $elem, $i);
176        } continue {
177            $i++;
178        }
179
1
50
12
        $success = $rows_affected == @$data ? 1 : 0;
180    } else {
181
0
0
        die "Only non-empty hashes or arrays are expected.\n";
182    }
183
7
62
    my $last_id = $self->last_insert_id('_access_rules');
184    return {
185
7
50
50
177
        success => $success,
186        rows_affected => $rows_affected >= 0 ? $rows_affected : 0,
187        last_row => $last_id ? "/=/role/$role/id/$last_id" : undef,
188    };
189}
190
191sub insert_rule {
192
10
10
0
69
    my ($self, $role, $data, $row) = @_;
193
10
60
    my $id = delete $data->{id};
194
10
50
52
    if (defined $id) {
195
0
0
        $self->warn("row $row: Column \"id\" ignored.");
196    }
197
10
100
99
    my $method = delete $data->{method} || 'GET';
198
10
50
59
    _STRING($method) or
199        die "row $row: Column \"method\" is not a string: ", $Dumper->($method), "\n";
200
10
50
280
    if ($method !~ /^(?:GET|POST|PUT|DELETE|HEAD)$/) {
201
0
0
        die "row $row: Unrecognized HTTP method: $method\n";
202    }
203
10
66
    my $url = delete $data->{url};
204
10
100
55
    if (!defined $url) {
205
1
4
        die "row $row: Column \"url\" is missing.\n";
206    }
207
9
50
74
    if ($url !~ /^\/=\//) {
208
0
0
        die "URL must be lead by \"/=/\".\n";
209    }
210
9
50
53
    if (%$data) {
211
0
0
        die "Unrecognized keys found in row $row: ",
212            join(" ", keys %$data),
213            "\n";
214    }
215
9
91
    my $insert = SQL::Insert->new("_access_rules")
216        ->cols( qw< role method url > )
217        ->values( Q( $role, $method, $url ) );
218
9
75
    return $self->do($insert);
219}
220
221sub GET_role_list {
222
3
3
0
20
    my ($self, $bits) = @_;
223
3
28
    my $select = SQL::Select->new(
224        qw< name description >
225    )->from('_roles');
226
3
8
    my $roles = $self->select("$select", { use_hash => 1 });
227
228
3
50
53
    $roles ||= [];
229
3
7
17
78
    map { $_->{src} = "/=/role/$_->{name}" } @$roles;
230
3
9
    $roles;
231}
232
233sub GET_role {
234
13
13
0
95
    my ($self, $bits) = @_;
235
13
73
    my $role = $bits->[1];
236
13
100
88
    if ($role eq '~') {
237
1
7
        return $self->GET_role_list;
238    }
239
12
81
    my $role_id = $self->has_role($role);
240
12
100
547
    if (!$role_id) {
241
2
9
        die "Role \"$role\" not found.\n";
242    }
243
10
105
    my $select = SQL::Select->new( qw< name description login > )
244        ->from('_roles')
245        ->where(name => Q($role));
246
247
10
33
    my $res = $self->select("$select", {use_hash => 1})->[0];
248
10
385
    $res->{columns} = [
249        { name => "method", type => "text", label => "HTTP method" },
250        { name => "url", type => "text", label => "Resource"}
251    ];
252
10
32
    return $res;
253}
254
255sub DELETE_role_list {
256
3
3
0
21
    my ($self, $bits) = @_;
257
3
14
    my $sql = "delete from _access_rules where role <> 'Admin' and role <> 'Public';\n".
258        "delete from _roles where name <> 'Admin' and name <> 'Public'";
259
3
23
    $self->warning("Predefined roles skipped.");
260
3
50
21
    return { success => $self->do($sql) >= 0 ? 1 : 0 };
261}
262
263sub current_user_can {
264
520
520
0
3893
    my ($self, $meth, $bits) = @_;
265
520
3062
    my @urls = $bits;
266
520
3042
    my $role = $self->{_role};
267
520
3118
    my $max_i = @$bits - 1;
268
520
4309
    while ($max_i >= 1) {
269
946
946
3082
8209
        my @last_bits = @{ $urls[-1] };
270
946
100
7842
        if ($last_bits[$max_i] ne '~') {
271
681
3285
            $last_bits[$max_i] = '~';
272
681
4820
            push @urls, \@last_bits;
273        }
274
946
7706
    } continue { $max_i-- }
275
520
1201
2626
12864
    map { $_ = '/=/' . join '/', @$_ } @urls;
276
520
1201
3645
7891
    my $or_clause = join ' or ', map { "url = ".Q($_) } @urls;
277
520
3944
    my $sql = "select count(*) from _access_rules where role = ".
278        Q($role) . " and method = " . Q($meth) . " and ($or_clause);";
279    ### $sql
280
520
4027
    my $res = $self->select($sql);
281
520
520
527623
8125
    return do { $res->[0][0] };
282}
283
284sub POST_role {
285
10
10
0
80
    my ($self, $bits) = @_;
286
10
50
111
    my $data = _HASH($self->{_req_data}) or
287        die "The role schema must be a HASH.\n";
288
10
371
    my $role = $bits->[1];
289
290
10
35
    my $name;
291
10
50
61
    if ($role eq '~') {
292
0
0
        $role = $data->{name};
293    }
294
295
10
50
33
106
    if ($name = delete $data->{name} and $name ne $role) {
296
0
0
        $self->warning("name \"$name\" in POST content ignored.");
297    }
298
299
10
71
    $data->{name} = $role;
300
10
82
    return $self->new_role($data);
301}
302
303sub role_count {
304
10
10
0
56
    my $self = shift;
305
10
74
    return $self->select("select count(*) from _roles")->[0][0];
306}
307
308sub new_role {
309
10
10
0
62
    my ($self, $data) = @_;
310
10
57
    my $nroles = $self->role_count;
311
10
6439
    my $res;
312
10
50
110
    if ($nroles >= $ROLE_LIMIT) {
313
0
0
        die "Exceeded role count limit $ROLE_LIMIT.\n";
314    }
315
316
10
50
98
    my $name = delete $data->{name} or
317        die "No 'name' specified.\n";
318
10
50
74
    _IDENT($name) or die "Bad role name: ", $Dumper->($name), "\n";
319
10
100
92
    if ($self->has_role($name)) {
320
1
4
        die "Role \"$name\" already exists.\n";
321    }
322
323
9
431
    my $desc = delete $data->{description};
324
9
100
78
    if (!defined $desc) {
325
1
4
        die "Field 'description' is missing.\n";
326    }
327
8
50
76
    _STRING($desc) or die "Role description must be a string.\n";
328
329
8
219
    my $login = delete $data->{login};
330
8
100
59
    if (!defined $login) {
331
1
4
        die "No 'login' field specified.\n";
332    }
333
7
50
46
    _STRING($login) or die "Bad 'login' value: ", $Dumper->($login), "\n";
334
335
7
100
200
    if ($login !~ /^(?:password|captcha|anonymous)$/) {
336
1
5
        die "Unknown login method: $login\n";
337    }
338
339
6
41
    my $password = delete $data->{password};
340
6
50
67
92
    if (defined $password and $login ne 'password') {
341
0
0
        $self->warning("Field 'password' ignored.");
342    }
343
344
6
100
47
    if ($login eq 'password') {
345
5
100
100
54
        if (!defined $password) {
346
1
5
            die "No password given when 'login' is 'password'.\n";
347        } elsif (length($password) < $PASSWORD_MIN_LEN) {
348
2
9
            die "Password too short; at least $PASSWORD_MIN_LEN chars required.\n";
349        }
350    }
351
352
3
50
23
    if (%$data) {
353
0
0
        die "Unknown keys: ", join(" ", keys %$data), "\n";
354    }
355
356
3
35
    my $insert = SQL::Insert
357        ->new('_roles')
358        ->cols( qw<name description login password> )
359        ->values( Q($name, $desc, $login, $password) );
360
361
3
50
33
    return { success => $self->do($insert) ? 1 : 0 };
362}
363
364sub PUT_role {
365
28
28
0
216
    my ($self, $bits) = @_;
366
28
172
    my $role = $bits->[1];
367
28
50
276
    my $data = _HASH($self->{_req_data}) or
368        die "column spec must be a non-empty HASH.\n";
369    ### $data
370
28
50
1082
    die "Role \"$role\" not found.\n" unless $self->has_role($role);
371
28
1237
    my $extra_sql = '';
372
373
28
318
    my $update = SQL::Update->new('_roles');
374
28
243
    $update->where(name => Q($role));
375
376
28
218
    my $new_name = delete $data->{name};
377
28
100
200
    if (defined $new_name) {
378
3
50
22
        _IDENT($new_name) or die "Bad role name: ", $Dumper->($new_name);
379
3
22
        $update->set( name => Q($new_name) );
380
3
21
        $extra_sql .= 'update _access_rules set role='.Q($new_name).' where role='.Q($role).';';
381    }
382
383
28
180
    my $new_login = delete $data->{login};
384
28
100
175
    if (defined $new_login) {
385
13
100
113
        _STRING($new_login) or
386            die "Bad login method: ", $Dumper->($new_login), "\n";
387
11
100
367
        if ($new_login !~ /^(?:password|anonymous|captcha)$/) {
388
1
6
            die "Bad login method: $new_login\n";
389        }
390
10
72
        $update->set(login => Q($new_login));
391    }
392
393
25
162
    my $new_password = delete $data->{password};
394
25
100
165
    if (defined $new_password) {
395
14
100
100
189
        if (defined $new_login && $new_login ne 'password') {
396
2
6
            die "Password given when 'login' is not 'password'.\n";
397        }
398
12
50
99
        _STRING($new_password) or
399            die "Bad password: ", $Dumper->($new_password), "\n";
400
12
355
        check_password($new_password);
401
11
82
        $update->set(password => Q($new_password));
402    }
403
404
22
100
100
331
    if (defined $new_login and $new_login eq 'password' and !defined $new_password) {
405
2
7
        die "No password given when 'login' is 'password'.\n";
406    }
407
408
20
122
    my $new_desc = delete $data->{description};
409
20
100
116
    if (defined $new_desc) {
410
6
100
50
        _STRING($new_desc) or die "Bad role definition: ", $Dumper->($new_desc), "\n";
411
4
123
        $update->set(description => Q($new_desc));
412    }
413    ### Update SQL: "$update"
414
18
50
108
    if (%$data) {
415
0
0
        die "Unknown keys in POST data: ", join(' ', keys %$data), "\n";
416    }
417
18
51
    my $retval = $self->do("$update" . $extra_sql) + 0;
418
18
50
57
    return { success => $retval >= 0 ? 1 : 0 };
419}
420
4211;
422