File Coverage

blib/lib/Net/Proxmox/VE/Access.pm
Criterion Covered Total %
statement 15 197 7.6
branch 0 186 0.0
condition 0 24 0.0
subroutine 5 32 15.6
pod 27 27 100.0
total 47 466 10.0


line stmt bran cond sub pod time code
1             #!/bin/false
2             # vim: softtabstop=2 tabstop=2 shiftwidth=2 ft=perl expandtab smarttab
3             # PODNAME: Net::Proxmox::VE::Access
4             # ABSTRACT: Functions for the 'access' portion of the API
5              
6 1     1   8 use strict;
  1         1  
  1         40  
7 1     1   5 use warnings;
  1         2  
  1         49  
8              
9             package Net::Proxmox::VE::Access;
10             $Net::Proxmox::VE::Access::VERSION = '0.38';
11 1     1   5 use parent 'Exporter';
  1         3  
  1         4  
12              
13 1     1   65 use Carp qw( croak );
  1         2  
  1         46  
14              
15 1     1   5 use JSON::MaybeXS qw(decode_json);
  1         11  
  1         2403  
16              
17             our @EXPORT =
18             qw(
19             access
20             access_domains access_groups access_roles
21             create_access_domains create_access_groups create_access_roles create_access_users
22             delete_access_domains delete_access_groups delete_access_roles delete_access_users
23             get_access_domains get_access_groups get_access_roles get_access_users
24             update_access_domains update_access_groups update_access_roles update_access_users
25             login check_login_ticket clear_login_ticket
26             get_access_acl update_access_acl
27             update_access_password
28             );
29              
30              
31             my $base = '/access';
32              
33             sub access {
34              
35 0 0   0 1   my $self = shift or return;
36              
37 0           return $self->get($base);
38              
39             }
40              
41              
42             sub access_domains {
43              
44 0 0   0 1   my $self = shift or return;
45              
46 0           return $self->get( $base, 'domains' )
47              
48             }
49              
50              
51             sub create_access_domains {
52              
53 0 0   0 1   my $self = shift or return;
54 0           my @p = @_;
55              
56 0 0         croak 'No arguments for create_access_domains()' unless @p;
57 0           my %args;
58              
59 0 0         if ( @p == 1 ) {
60 0 0         croak 'Single argument not a hash for create_access_domains()'
61             unless ref $a eq 'HASH';
62 0           %args = %{ $p[0] };
  0            
63             }
64             else {
65 0 0         croak 'Odd number of arguments for create_access_domains()'
66             if ( scalar @p % 2 != 0 );
67 0           %args = @p;
68             }
69              
70 0           return $self->post( $base, 'domains', \%args )
71              
72             }
73              
74              
75             sub get_access_domains {
76              
77 0 0   0 1   my $self = shift or return;
78              
79 0 0         my $a = shift or croak 'No realm for get_access_domains()';
80 0 0         croak 'realm must be a scalar for get_access_domains()' if ref $a;
81              
82 0           return $self->get( $base, 'domains', $a )
83              
84             }
85              
86              
87             sub update_access_domains {
88              
89 0 0   0 1   my $self = shift or return;
90 0 0         my $realm = shift or croak 'No realm provided for update_access_domains()';
91 0 0         croak 'realm must be a scalar for update_access_domains()' if ref $realm;
92 0           my @p = @_;
93              
94 0 0         croak 'No arguments for update_access_domains()' unless @p;
95 0           my %args;
96              
97 0 0         if ( @p == 1 ) {
98 0 0         croak 'Single argument not a hash for update_access_domains()'
99             unless ref $a eq 'HASH';
100 0           %args = %{ $p[0] };
  0            
101             }
102             else {
103 0 0         croak 'Odd number of arguments for update_access_domains()'
104             if ( scalar @p % 2 != 0 );
105 0           %args = @p;
106             }
107              
108 0           return $self->put( $base, 'domains', $realm, \%args )
109              
110             }
111              
112              
113             sub delete_access_domains {
114              
115 0 0   0 1   my $self = shift or return;
116 0 0         my $a = shift or croak 'No argument given for delete_access_domains()';
117              
118 0           return $self->delete( $base, 'domains', $a )
119              
120             }
121              
122              
123             sub access_groups {
124              
125 0 0   0 1   my $self = shift or return;
126              
127 0           return $self->get( $base, 'groups' )
128              
129             }
130              
131              
132             sub create_access_groups {
133              
134 0 0   0 1   my $self = shift or return;
135 0           my @p = @_;
136              
137 0 0         croak 'No arguments for create_access_groups()' unless @p;
138 0           my %args;
139              
140 0 0         if ( @p == 1 ) {
141 0 0         croak 'Single argument not a hash for create_access_groups()'
142             unless ref $a eq 'HASH';
143 0           %args = %{ $p[0] };
  0            
144             }
145             else {
146 0 0         croak 'Odd number of arguments for create_access_groups()'
147             if ( scalar @p % 2 != 0 );
148 0           %args = @p;
149             }
150              
151 0           return $self->post( $base, 'groups', \%args )
152              
153             }
154              
155              
156             sub get_access_groups {
157              
158 0 0   0 1   my $self = shift or return;
159              
160 0 0         my $a = shift or croak 'No groupid for get_access_groups()';
161 0 0         croak 'groupid must be a scalar for get_access_groups()' if ref $a;
162              
163 0           return $self->get( $base, 'groups', $a )
164              
165             }
166              
167              
168             sub update_access_groups {
169              
170 0 0   0 1   my $self = shift or return;
171 0 0         my $realm = shift or croak 'No realm provided for update_access_groups()';
172 0 0         croak 'realm must be a scalar for update_access_groups()' if ref $realm;
173 0           my @p = @_;
174              
175 0 0         croak 'No arguments for update_access_groups()' unless @p;
176 0           my %args;
177              
178 0 0         if ( @p == 1 ) {
179 0 0         croak 'Single argument not a hash for update_access_groups()'
180             unless ref $a eq 'HASH';
181 0           %args = %{ $p[0] };
  0            
182             }
183             else {
184 0 0         croak 'Odd number of arguments for update_access_groups()'
185             if ( scalar @p % 2 != 0 );
186 0           %args = @p;
187             }
188              
189 0           return $self->put( $base, 'groups', $realm, \%args )
190              
191             }
192              
193              
194             sub delete_access_groups {
195              
196 0 0   0 1   my $self = shift or return;
197 0 0         my $a = shift or croak 'No argument given for delete_access_groups()';
198              
199 0           return $self->delete( $base, 'groups', $a )
200              
201             }
202              
203              
204              
205             sub access_roles {
206              
207 0 0   0 1   my $self = shift or return;
208              
209 0           return $self->get( $base, 'roles' )
210              
211             }
212              
213              
214             sub create_access_roles {
215              
216 0 0   0 1   my $self = shift or return;
217 0           my @p = @_;
218              
219 0 0         croak 'No arguments for create_access_roles()' unless @p;
220 0           my %args;
221              
222 0 0         if ( @p == 1 ) {
223 0 0         croak 'Single argument not a hash for create_access_roles()'
224             unless ref $a eq 'HASH';
225 0           %args = %{ $p[0] };
  0            
226             }
227             else {
228 0 0         croak 'Odd number of arguments for create_access_roles()'
229             if ( scalar @p % 2 != 0 );
230 0           %args = @p;
231             }
232              
233 0           return $self->post( $base, 'roles', \%args )
234              
235             }
236              
237              
238             sub get_access_roles {
239              
240 0 0   0 1   my $self = shift or return;
241              
242 0 0         my $a = shift or croak 'No roleid for get_access_roles()';
243 0 0         croak 'roleid must be a scalar for get_access_roles()' if ref $a;
244              
245 0           return $self->get( $base, 'roles', $a )
246              
247             }
248              
249              
250             sub update_access_roles {
251              
252 0 0   0 1   my $self = shift or return;
253 0 0         my $realm = shift or croak 'No realm provided for update_access_roles()';
254 0 0         croak 'realm must be a scalar for update_access_roles()' if ref $realm;
255 0           my @p = @_;
256              
257 0 0         croak 'No arguments for update_access_roles()' unless @p;
258 0           my %args;
259              
260 0 0         if ( @p == 1 ) {
261 0 0         croak 'Single argument not a hash for update_access_roles()'
262             unless ref $a eq 'HASH';
263 0           %args = %{ $p[0] };
  0            
264             }
265             else {
266 0 0         croak 'Odd number of arguments for update_access_roles()'
267             if ( scalar @p % 2 != 0 );
268 0           %args = @p;
269             }
270              
271 0           return $self->put( $base, 'roles', $realm, \%args )
272              
273             }
274              
275              
276             sub delete_access_roles {
277              
278 0 0   0 1   my $self = shift or return;
279 0 0         my $a = shift or croak 'No argument given for delete_access_roles()';
280              
281 0           return $self->delete( $base, 'roles', $a )
282              
283             }
284              
285              
286              
287             sub access_users {
288              
289 0 0   0 1   my $self = shift or return;
290              
291 0           return $self->get( $base, 'users' )
292              
293             }
294              
295              
296             sub create_access_users {
297              
298 0 0   0 1   my $self = shift or return;
299 0           my @p = @_;
300              
301 0 0         croak 'No arguments for create_access_users()' unless @p;
302 0           my %args;
303              
304 0 0         if ( @p == 1 ) {
305 0 0         croak 'Single argument not a hash for create_access_users()'
306             unless ref $a eq 'HASH';
307 0           %args = %{ $p[0] };
  0            
308             }
309             else {
310 0 0         croak 'Odd number of arguments for create_access_users()'
311             if ( scalar @p % 2 != 0 );
312 0           %args = @p;
313             }
314              
315 0           return $self->post( $base, 'users', \%args )
316              
317             }
318              
319              
320             sub get_access_users {
321              
322 0 0   0 1   my $self = shift or return;
323              
324 0 0         my $a = shift or croak 'No userid for get_access_users()';
325 0 0         croak 'userid must be a scalar for get_access_users()' if ref $a;
326              
327 0           return $self->get( $base, 'users', $a )
328              
329             }
330              
331              
332             sub update_access_users {
333              
334 0 0   0 1   my $self = shift or return;
335 0 0         my $realm = shift or croak 'No realm provided for update_access_users()';
336 0 0         croak 'realm must be a scalar for update_access_users()' if ref $realm;
337 0           my @p = @_;
338              
339 0 0         croak 'No arguments for update_access_users()' unless @p;
340 0           my %args;
341              
342 0 0         if ( @p == 1 ) {
343 0 0         croak 'Single argument not a hash for update_access_users()'
344             unless ref $a eq 'HASH';
345 0           %args = %{ $p[0] };
  0            
346             }
347             else {
348 0 0         croak 'Odd number of arguments for update_access_users()'
349             if ( scalar @p % 2 != 0 );
350 0           %args = @p;
351             }
352              
353 0           return $self->put( $base, 'users', $realm, \%args )
354              
355             }
356              
357              
358             sub delete_access_users {
359              
360 0 0   0 1   my $self = shift or return;
361 0 0         my $a = shift or croak 'No argument given for delete_access_users()';
362              
363 0           return $self->delete( $base, 'users', $a )
364              
365             }
366              
367              
368             sub check_login_ticket {
369              
370 0 0   0 1   my $self = shift or return;
371              
372 0 0 0       if ( $self->{ticket}
      0        
      0        
      0        
      0        
      0        
      0        
373             && ref $self->{ticket} eq 'HASH'
374             && $self->{ticket}
375             && $self->{ticket}->{ticket}
376             && $self->{ticket}->{CSRFPreventionToken}
377             && $self->{ticket}->{username} eq $self->{params}->{username} . '@'
378             . $self->{params}->{realm}
379             && $self->{ticket_timestamp}
380             && ( $self->{ticket_timestamp} + $self->{ticket_life} ) > time() )
381             {
382 0           return 1;
383             }
384             else {
385 0           $self->clear_login_ticket;
386             }
387              
388             return
389              
390 0           }
391              
392              
393             sub clear_login_ticket {
394              
395 0 0   0 1   my $self = shift or return;
396              
397 0 0 0       if ( $self->{ticket} or $self->{timestamp} ) {
398 0           $self->{ticket} = undef;
399 0           $self->{ticket_timestamp} = undef;
400 0           return 1;
401             }
402              
403             return
404              
405 0           }
406              
407              
408             sub get_access_acl {
409              
410 0 0   0 1   my $self = shift or return;
411              
412 0           return $self->get( $base, 'acl' );
413              
414             }
415              
416              
417             sub login {
418 0 0   0 1   my $self = shift or return;
419              
420             # Prepare login request
421 0           my $url = $self->url_prefix . '/api2/json/access/ticket';
422              
423             # Perform login request
424 0           my $request_time = time();
425             my $response = $self->{ua}->post(
426             $url,
427             {
428             'username' => $self->{params}->{username} . '@'
429             . $self->{params}->{realm},
430             'password' => $self->{params}->{password},
431             },
432 0           );
433              
434 0 0         if ( $response->is_success ) {
435             # my $content = $response->decoded_content;
436 0           my $login_ticket_data = decode_json( $response->decoded_content );
437 0           $self->{ticket} = $login_ticket_data->{data};
438              
439             # We use request time as the time to get the json ticket is undetermined,
440             # id rather have a ticket a few seconds shorter than have a ticket that incorrectly
441             # says its valid for a couple more
442 0           $self->{ticket_timestamp} = $request_time;
443             print "DEBUG: login successful\n"
444 0 0         if $self->{params}->{debug};
445 0           return 1;
446             }
447             else {
448              
449             print "DEBUG: login not successful\n"
450 0 0         if $self->{params}->{debug};
451             print "DEBUG: " . $response->status_line . "\n"
452 0 0         if $self->{params}->{debug};
453              
454             }
455              
456 0           return;
457             }
458              
459              
460             sub update_access_acl {
461              
462 0 0   0 1   my $self = shift or return;
463 0           my @p = @_;
464              
465 0 0         croak 'No arguments for update_acl()' unless @p;
466 0           my %args;
467              
468 0 0         if ( @p == 1 ) {
469 0 0         croak 'Single argument not a hash for update_acl()'
470             unless ref $a eq 'HASH';
471 0           %args = %{ $p[0] };
  0            
472             }
473             else {
474 0 0         croak 'Odd number of arguments for update_acl()'
475             if ( scalar @p % 2 != 0 );
476 0           %args = @p;
477             }
478              
479 0           return $self->put( $base, 'acl', \%args )
480              
481             }
482              
483              
484             sub update_access_password {
485              
486 0 0   0 1   my $self = shift or return;
487 0           my @p = @_;
488              
489 0 0         croak 'No arguments for update_password()' unless @p;
490 0           my %args;
491              
492 0 0         if ( @p == 1 ) {
493 0 0         croak 'Single argument not a hash for update_password()'
494             unless ref $a eq 'HASH';
495 0           %args = %{ $p[0] };
  0            
496             }
497             else {
498 0 0         croak 'Odd number of arguments for update_password()'
499             if ( scalar @p % 2 != 0 );
500 0           %args = @p;
501             }
502              
503 0           return $self->put( $base, 'password', \%args )
504              
505             }
506              
507              
508             1;
509              
510             __END__