File Coverage

blib/lib/WWW/Suffit/AuthDB.pm
Criterion Covered Total %
statement 218 274 79.5
branch 71 134 52.9
condition 41 97 42.2
subroutine 30 35 85.7
pod 18 18 100.0
total 378 558 67.7


line stmt bran cond sub pod time code
1             package WWW::Suffit::AuthDB;
2 3     3   646605 use strict;
  3         7  
  3         123  
3 3     3   17 use warnings;
  3         10  
  3         199  
4 3     3   1029 use utf8;
  3         708  
  3         19  
5              
6             =encoding utf8
7              
8             =head1 NAME
9              
10             WWW::Suffit::AuthDB - Suffit Authorization Database
11              
12             =head1 SYNOPSIS
13              
14             use WWW::Suffit::AuthDB;
15              
16             my $authdb = WWW::Suffit::AuthDB->new(
17             ds => "sqlite:///tmp/auth.db?sqlite_unicode=1"
18             );
19              
20             =head1 DESCRIPTION
21              
22             Suffit Authorization Database
23              
24             =head1 ATTRIBUTES
25              
26             This class implements the following attributes
27              
28             =head2 cached
29              
30             cached => 1
31             cached => 'yes'
32             cached => 'on'
33             cached => 'enable'
34              
35             This attribute performs enabling caching while establishing of connection with database
36              
37             $authdb = $authdb->cached("On");
38             my $cached = $authdb->cached;
39              
40             Default: false (no caching connection)
41              
42             =head2 initialized
43              
44             initialized => 1
45             initialized => 'yes'
46             initialized => 'on'
47             initialized => 'enable'
48              
49             This attribute marks the schema as initialized or performs read this status
50              
51             =head2 code
52              
53             code => undef
54              
55             Read only attribute to get the HTTP code
56              
57             my $code = $authdb->code; # 200
58              
59             =head2 data
60              
61             data => undef
62              
63             Read only attribute to get the current data pool
64              
65             my $data = $authdb->data;
66              
67             =head2 ds, dsuri
68              
69             ds => "sqlite:///tmp/auth.db?sqlite_unicode=1"
70              
71             Data source URI. See L
72              
73             $authdb = $authdb->ds("sqlite:///tmp/auth.db?sqlite_unicode=1");
74             my $ds = $authdb->ds;
75              
76             Default: 'sponge://'
77              
78             =head2 error
79              
80             error => undef
81              
82             Read only attribute to get the error message
83              
84             my $error = $authdb->error;
85              
86             =head2 expiration
87              
88             expiration => 300
89              
90             The expiration time
91              
92             $authdb = $authdb->expiration(60*5);
93             my $expiration = $authdb->expiration;
94              
95             B This attribute MUST be defined before first calling the cache method
96              
97             Default: 300 (5 min)
98              
99             =head2 max_keys
100              
101             max_keys => 1024
102              
103             The maximum keys number in cache
104              
105             $authdb = $authdb->max_keys(1024*10);
106             my $max_keys = $authdb->max_keys;
107              
108             B This attribute MUST be defined before first calling the cache method
109              
110             Default: 1024*1024 (1`048`576 keys max)
111              
112             =head2 sourcefile
113              
114             sourcefile => '/tmp/authdb.json'
115              
116             Path to the source file in JSON format
117              
118             $authdb = $authdb->sourcefile("/tmp/authdb.json");
119             my $sourcefile = $authdb->sourcefile;
120              
121             Default: none
122              
123             =head1 METHODS
124              
125             This class inherits all methods from L and implements the following new ones
126              
127             =head2 new
128              
129             my $authdb = WWW::Suffit::AuthDB->new(
130             ds => "sqlite:///tmp/auth.db?sqlite_unicode=1",
131             sourcefile => "/tmp/authdb.json"
132             );
133             die $authdb->error if $authdb->error;
134              
135             Create new AuthDB object
136              
137              
138             =head2 cache
139              
140             my $cache = $authdb->cache;
141              
142             Get cache instance
143              
144             =head2 cached_group
145              
146             This method is deprecated. See L method
147              
148             =head2 cached_realm
149              
150             This method is deprecated. See L method
151              
152             =head2 cached_routes
153              
154             This method is deprecated. See L method
155              
156             =head2 cached_user
157              
158             This method is deprecated. See L method
159              
160             =head2 checksum
161              
162             my $digest = $authdb->checksum("string", "algorithm");
163              
164             This method generates checksum for string.
165             Supported algorithms: MD5 (unsafe), SHA1 (unsafe), SHA224, SHA256, SHA384, SHA512
166             Default algorithm: SHA256
167              
168             =head2 clean
169              
170             $authdb->clean;
171              
172             Cleans state vars on the AuthDB object and returns it
173              
174             =head2 connect
175              
176             $authdb->connect;
177             $authdb->connect('yes'); # cached connection
178              
179             This method performs regular or cached connection with database. See also L attribute
180              
181             =head2 dump
182              
183             print $authdb->dump;
184              
185             Returns JSON dump of loaded authentication database
186              
187             =head2 group
188              
189             my $group = $authdb->group("manager");
190              
191             This method returns data of specified groupname as L object
192              
193             my $group = $authdb->group("manager", 'd1b919c1');
194              
195             With this data (with pair of arguments) the method returns cached data of specified groupname
196             as L object by cachekey
197              
198             my $group = $authdb->group("manager", 'd1b919c1', 1);
199              
200             The third parameter (ForceUpdate=true) allows you to forcefully get data from the database
201              
202             =head2 is_connected
203              
204             $authdb->connect unless $authdb->is_connected
205              
206             This method checks connection status
207              
208             =head2 load
209              
210             $authdb->load("/tmp/authdb.json");
211             die $authdb->error if $authdb->error;
212              
213             $authdb->load(); # from `sourcefile`
214             die $authdb->error if $authdb->error;
215              
216             This method performs loading file to C pool
217              
218             =head2 model
219              
220             my $model = $authdb->model;
221              
222             Get model L instance
223              
224             =head2 raise
225              
226             return $authdb->raise("Error string");
227             return $authdb->raise("Error %s", "string");
228             return $authdb->raise(200 => "Error string");
229             return $authdb->raise(200 => "Error %s", "string");
230              
231             Sets error string and returns false status (undef). Also this method can performs sets the HTTP status code
232              
233             =head2 realm
234              
235             my $realm = $authdb->realm("default");
236              
237             This method returns data of specified realm name as L object
238              
239             my $realm = $authdb->realm("default", 'd1b919c1');
240              
241             With this data (with pair of arguments) the method returns cached data of specified realm name
242             as L object by cachekey
243              
244             my $realm = $authdb->realm("default", 'd1b919c1', 1);
245              
246             The third parameter (ForceUpdate=true) allows you to forcefully get data from the database
247              
248             =head2 routes
249              
250             my $routes = $authdb->routes("http://localhost/");
251             my $routes = $authdb->routes("http://localhost/", 'd1b919c1');
252             my $routes = $authdb->routes("http://localhost/", 'd1b919c1', 1);
253              
254             This method returns hash of routes by base URL and cachekey (optionaly).
255             With pair of arguments the method returns cached data by cachekey.
256             The third parameter (ForceUpdate=true) allows you to forcefully get data from the database
257              
258             =head2 save
259              
260             $authdb->save(); # to `sourcefile`
261             die $authdb->error if $authdb->error;
262              
263             Performs flush database to file that was specified in constructor
264              
265             $authdb->save("/tmp/new-authdb.json");
266             die $authdb->error if $authdb->error;
267              
268             Performs flush database to file that specified directly
269              
270             =head2 user
271              
272             my $user = $authdb->user("alice");
273              
274             This method returns data of specified username as L object
275              
276             my $user = $authdb->user("alice", 'd1b919c1');
277              
278             Returns cached data of specified username as L object by cachekey
279              
280             my $user = $authdb->user("alice", 'd1b919c1', 1);
281              
282             The third parameter (ForceUpdate=true) allows you to forcefully get data from the database
283              
284             =head2 META KEYS
285              
286             Meta keys define the AuthDB setting parameters
287              
288             =over 4
289              
290             =item schema.version
291              
292             Version of the current schema
293              
294             =back
295              
296             =head1 ERROR CODES
297              
298             List of AuthDB Suffit API error codes
299              
300             API | HTTP | DESCRIPTION
301             -------+-------+-------------------------------------------------
302             E1300 [500] Can't load file. File not found
303             E1301 [500] Can't load data pool from file
304             E1302 [500] File did not return a JSON object
305             E1303 [500] Can't serialize data pool to JSON
306             E1304 [500] Can't save data pool to file
307             E1305 [500] Can't connect to database (model)
308             E1306 [500] Connection failed
309             E1307 [500] The authorization database is not initialized
310             E1308 [---] Reserved
311             E1309 [---] Reserved
312             E1310 [ * ] User not found
313             E1311 [ * ] Incorrect username stored
314             E1312 [ * ] Incorrect password stored
315             E1313 [ * ] The user data is expired
316             E1314 [ * ] Group not found
317             E1315 [ * ] Incorrect groupname stored
318             E1316 [ * ] The group data is expired
319             E1317 [403] External requests is blocked
320             E1318 [403] Internal requests is blocked
321             E1319 [403] Access denied
322             E1320 [400] No username specified
323             E1321 [413] The username is too long (1-256 chars required)
324             E1322 [400] No password specified
325             E1323 [413] The password is too long (1-256 chars required)
326             E1324 [403] Account frozen for 5 min
327             E1325 [501] Incorrect digest algorithm
328             E1326 [401] Incorrect username or password
329             E1327 [403] User is disabled
330             E1328 [---] Reserved
331             E1329 [500] Database request error (meta_get)
332             E1330 [400] No key specified
333             E1331 [500] Database request error (meta_set)
334             E1332 [400] Incorrect digest algorithm
335             E1333 [500] Database request error (user_get)
336             E1334 [400] User already exists
337             E1335 [500] Database request error (user_add)
338             E1336 [400] User not found
339             E1337 [500] Database request error (user_edit)
340             E1338 [500] Database request error (user_getall)
341             E1339 [500] Database request error (meta_del)
342             E1340 [500] Database request error (user_del)
343             E1341 [500] Database request error (grpusr_del)
344             E1342 [500] Database request error (user_search)
345             E1343 [500] Database request error (user_groups)
346             E1344 [400] No password specified
347             E1345 [500] Database request error (user_passwd)
348             E1346 [500] Database request error (user_setkeys)
349             E1347 [500] Database request error (user_tokens)
350             E1348 [500] Database request error (group_get)
351             E1349 [400] Group already exists
352             E1350 [500] Database request error (group_add)
353             E1351 [500] Database request error (user_set)
354             E1352 [500] Database request error (grpusr_add)
355             E1353 [500] Database request error (group_set)
356             E1354 [---] Reserved
357             E1355 [500] Database request error (group_getall)
358             E1356 [500] Database request error (group_del)
359             E1357 [500] Database request error (grpusr_get)
360             E1358 [500] Database request error (group_members)
361             E1359 [500] Database request error (realm_get)
362             E1360 [400] Realm already exists
363             E1361 [500] Database request error (realm_add)
364             E1362 [500] Database request error (route_release)
365             E1363 [500] Database request error (route_assign)
366             E1364 [500] Database request error (realm_requirement_del)
367             E1365 [500] Database request error (realm_requirement_add)
368             E1366 [500] Database request error (realm_set)
369             E1367 [500] Database request error (realm_getall)
370             E1368 [500] Database request error (realm_del)
371             E1369 [500] Database request error (token_add)
372             E1370 [500] Database request error (route_add)
373             E1371 [500] Database request error (realm_requirements)
374             E1372 [500] Database request error (realm_routes)
375             E1373 [500] Database request error (route_get)
376             E1374 [400] Route already exists
377             E1375 [500] Database request error (route_set)
378             E1376 [500] Database request error (route_getall)
379             E1377 [500] Database request error (route_del)
380             E1378 [500] Database request error (route_search)
381             E1379 [500] Database request error (token_del)
382             E1380 [500] Database request error (token_get)
383             E1381 [500] Database request error (token_get_cond)
384             E1382 [500] Database request error (token_set)
385             E1383 [500] Database request error (token_getall)
386             E1384 [500] Database request error (stat_get)
387             E1385 [500] Database request error (stat_set)
388              
389             B<*> -- this code will be defined later on the interface side
390              
391             See also list of common Suffit API error codes in L
392              
393             =head1 EXAMPLE
394              
395             Example of default authdb.json
396              
397             See C
398              
399             =head1 HISTORY
400              
401             See C file
402              
403             =head1 TO DO
404              
405             See C file
406              
407             =head1 SEE ALSO
408              
409             L, L
410              
411             =head1 AUTHOR
412              
413             Serż Minus (Sergey Lepenkov) L Eabalama@cpan.orgE
414              
415             =head1 COPYRIGHT
416              
417             Copyright (C) 1998-2026 D&D Corporation
418              
419             =head1 LICENSE
420              
421             This program is distributed under the terms of the Artistic License Version 2.0
422              
423             See the C file or L for details
424              
425             =cut
426              
427             our $VERSION = '1.07';
428              
429 3     3   2127 use Mojo::Base -base;
  3         28324  
  3         23  
430 3     3   2292 use Mojo::Util qw/md5_sum decode encode steady_time deprecated/;
  3         428172  
  3         608  
431 3     3   2015 use Mojo::File qw/path/;
  3         133749  
  3         308  
432 3     3   1931 use Mojo::JSON qw/from_json to_json/;
  3         115068  
  3         323  
433 3     3   5500 use Mojo::URL;
  3         34835  
  3         34  
434              
435 3     3   231 use Digest::SHA qw/sha1_hex sha224_hex sha256_hex sha384_hex sha512_hex/;
  3         6  
  3         327  
436              
437 3     3   6706 use Acrux::RefUtil qw/is_integer is_hash_ref is_true_flag is_void isnt_void/;
  3         11864  
  3         408  
438              
439 3     3   3487 use WWW::Suffit::Cache;
  3         6069  
  3         25  
440              
441 3     3   2822 use WWW::Suffit::AuthDB::Model;
  3         16  
  3         153  
442 3     3   2195 use WWW::Suffit::AuthDB::User;
  3         13  
  3         21  
443 3     3   1979 use WWW::Suffit::AuthDB::Group;
  3         50  
  3         22  
444 3     3   2122 use WWW::Suffit::AuthDB::Realm;
  3         63  
  3         44  
445              
446             use constant {
447 3         19496 DEFAULT_URL => 'http://localhost',
448             DEFAULT_ALGORITHM => 'SHA256',
449             MAX_CACHE_KEYS => 1024*1024, # 1`048`576 keys max
450             CACHE_EXPIRES => 60*5, # 5min
451 3     3   262 };
  3         7  
452              
453             has data => '';
454             has error => '';
455             has code => 200;
456             has sourcefile => ''; # JSON source file
457             has ds => ''; # Data Source URI
458             has dsuri => ''; # Data Source URI (= ds)
459             has max_keys => MAX_CACHE_KEYS;
460             has expiration => CACHE_EXPIRES;
461             has cached => 0;
462             has initialized => 0;
463              
464             sub raise {
465 3     3 1 40 my $self = shift(@_);
466 3 50       9 return undef unless scalar(@_);
467 3 50       9 if (@_ == 1) { # "message"
468 0         0 $self->error(shift(@_));
469             } else { # ("code", "message") || ("code", "format", "message") || ("format", "message")
470 3         6 my $code_or_format = shift @_; # Get fisrt arg
471 3 50       12 if (is_integer($code_or_format)) { # first is "code"
472 3         44 $self->code($code_or_format);
473 3 100       24 if (@_ == 1) { # second is "message"
474 2         7 $self->error(shift(@_));
475             } else { # "format", "message", ...
476 1         10 $self->error(sprintf(shift(@_), @_));
477             }
478             } else { # first is "format"
479 0         0 $self->error(sprintf($code_or_format, @_));
480             }
481             }
482 3         52 return undef;
483             }
484             sub clean {
485 86     86 1 231 my $self = shift;
486              
487             # Flush session variables
488 86         660 $self->error('');
489 86         1007 $self->code(200);
490 86         508 return $self;
491             }
492             sub cache {
493 3     3 1 4 my $self = shift;
494 3   50     15 $self->{cache} ||= WWW::Suffit::Cache->new(
      50        
      66        
495             max_keys => $self->max_keys // MAX_CACHE_KEYS,
496             expiration => $self->expiration // CACHE_EXPIRES,
497             );
498 3         62 return $self->{cache};
499             }
500             sub model {
501 86     86 1 2370 my $self = shift;
502 86   33     431 $self->{model} ||= WWW::Suffit::AuthDB::Model->new($self->dsuri || $self->ds);
      66        
503 86         1237 return $self->{model};
504             }
505             sub dump {
506 1     1 1 1799 my $self = shift;
507 1         18 to_json($self->{data});
508             }
509             sub load {
510 1     1 1 1600 my $self = shift;
511 1         4 my $file = shift;
512 1         8 $self->clean; # Flush error first
513 1 50       5 if ($file) {
514 0 0       0 $self->sourcefile($file) unless $self->sourcefile;
515             } else {
516 1         3 $file = $self->sourcefile;
517             }
518 1 50       9 return $self unless $file;
519 1 50 0     19 $self->raise(500 => "E1300: Can't load file \"$file\". File not found") && return $self
520             unless -e $file;
521              
522             # Load data pool from file
523 1         9 my $file_path = path($file);
524 1   50     34 my $cont = decode('UTF-8', $file_path->slurp) // '';
525 1 50       524 if (length($cont)) {
526 1         3 my $data = eval { from_json($cont) };
  1         6  
527 1 50       151 if ($@) {
    50          
528 0         0 $self->raise(500 => "E1301: Can't load data pool from file \"%s\": %s", $file, $@);
529             } elsif (ref($data) ne 'HASH') {
530 0         0 $self->raise(500 => "E1302: File \"%s\" did not return a JSON object", $file);
531             } else {
532 1         6 $self->{data} = $data;
533             }
534             }
535              
536 1         13 return $self;
537             }
538             sub save {
539 2     2 1 998 my $self = shift;
540 2   33     8 my $file = shift || $self->sourcefile;
541 2         9 $self->clean; # Flush error first
542 2 50       9 return $self unless $file;
543              
544             # Save data pool to file
545 2         5 my $json = eval { to_json($self->{data}) };
  2         12  
546 2 50       146 if ($@) {
547 0         0 $self->raise(500 => "E1303: Can't serialize data pool to JSON: %s", $@);
548 0         0 return $self;
549             }
550 2         10 path($file)->spew(encode('UTF-8', $json));
551 2 50 0     815 $self->raise(500 => "E1304: Can't save data pool to file \"%s\": %s", $file, ($! // 'unknown error')) unless -e $file;
552              
553 2         8 return $self;
554             }
555             sub connect {
556 2     2 1 1544 my $self = shift;
557 2         18 $self->clean; # Flush error first
558              
559             # Connect
560 2   33     22 my $cached = is_true_flag(shift // $self->cached);
561 2         75 my $model = $self->model;
562 2 50       10 if ($cached) {
563 0         0 $model->connect_cached;
564             } else {
565 2 50 33     38 $model->connect unless $model->dbh && $model->ping;
566             }
567 2 50       67201 if ($model->error) {
    50          
568 0         0 $self->raise(500 => "E1305: %s", $model->error);
569 0         0 return $self;
570             } elsif (!$model->ping) {
571 0         0 $self->raise(500 => "E1306: %s", "Connection failed");
572 0         0 return $self;
573             }
574              
575             # Check initialize status
576 2 100       229 unless (is_true_flag($self->initialized)) { # if NOT initialized
577 1 50       26 if ($model->is_initialized) {
578 1         6 $self->initialized(1); # On
579             } else {
580             # The authorization database is not inialized
581 0 0       0 $self->raise(500 => "E1307: %s", $model->error) if $model->error;
582             }
583             }
584              
585 2         55 return $self;
586             }
587             sub is_connected {
588 0     0 1 0 my $self = shift;
589 0         0 my $model = $self->model;
590 0 0       0 return 0 unless $model;
591 0 0       0 return 1 if $model->dbh;
592 0         0 return 0;
593             }
594             sub checksum {
595 9     9 1 1771 my $self = shift;
596 9   50     33 my $str = shift // '';
597 9   50     86 my $alg = uc(shift // DEFAULT_ALGORITHM);
598 9 50       34 return '' unless length $str;
599 9         52 my $enc_str = encode('UTF-8', $str);
600 9         153 my $h = '';
601 9 100       57 if ($alg eq 'MD5') { $h = md5_sum($enc_str) }
  3 100       23  
    100          
    100          
    100          
    50          
602 1         11 elsif ($alg eq 'SHA1') { $h = sha1_hex($enc_str) }
603 1         15 elsif ($alg eq 'SHA224') { $h = sha224_hex($enc_str) }
604 2         27 elsif ($alg eq 'SHA256') { $h = sha256_hex($enc_str) }
605 1         11 elsif ($alg eq 'SHA384') { $h = sha384_hex($enc_str) }
606 1         11 elsif ($alg eq 'SHA512') { $h = sha512_hex($enc_str) }
607 9         49 return $h;
608             }
609              
610             # Methods that returns sub-objects and hashes
611             sub user {
612 8     8 1 4610 my $self = shift;
613 8   50     33 my $username = shift // '';
614 8   100     64 my $cachekey = shift // '';
615 8         30 $cachekey =~ s/[^a-z0-9]/?/gi;
616 8   50     37 my $forceupdate = shift || 0;
617 8 100 50     30 my $key = $cachekey ? sprintf('u.%s.%s', $username || '__anonymous', $cachekey) : '';
618 8         46 $self->clean; # Flush errors
619              
620             # Check username
621 8 50       21 return WWW::Suffit::AuthDB::User->new() unless length($username); # No user specified
622              
623             # Get cached data
624 8 100       44 my $cached_data = $key ? $self->cache->get($key) : {};
625 8         44 my %data = ();
626 8 100 66     39 if (isnt_void($cached_data) && !$forceupdate) { # Data from cache unless defined $forceupdate
627 1 50       31 %data = isnt_void($cached_data) ? (%$cached_data) : ();
628             } else { # Data from model
629             # Get model
630 7         342 my $model = $self->model;
631              
632             # Get data from model
633 7         41 %data = $model->user_get($username);
634 7 50       328 if ($model->error) {
635 0         0 $self->raise(500 => "E1333: %s", $model->error);
636 0         0 return WWW::Suffit::AuthDB::User->new(error => $self->error);
637             }
638 7 100       83 return WWW::Suffit::AuthDB::User->new() unless $data{id}; # No user found - empty user data, no errors
639              
640             # Get groups list of user
641 4         22 my @grpusr = $model->grpusr_get( username => $username );
642 4 50       178 if ($model->error) {
643 0         0 $self->raise(500 => "E1357: %s", $model->error);
644 0         0 return WWW::Suffit::AuthDB::User->new(error => $self->error);
645             }
646 4         47 $data{groups} = [sort map {$_->{groupname}} @grpusr];
  13         51  
647              
648             # Set data from database to cache
649 4 100       27 if ($key) {
650 1         2 $data{is_cached} = 1;
651 1         6 $data{cached} = steady_time();
652 1         13 $data{cachekey} = $cachekey;
653 1         3 $self->cache->set($key, {%data});
654             }
655             }
656              
657             # Return User instance with %data
658 5         135 return WWW::Suffit::AuthDB::User->new(%data);
659             }
660             sub group {
661 1     1 1 1598 my $self = shift;
662 1   50     5 my $groupname = shift // '';
663 1   50     5 my $cachekey = shift // '';
664 1         3 $cachekey =~ s/[^a-z0-9]/?/gi;
665 1   50     4 my $forceupdate = shift || 0;
666 1 50 0     3 my $key = $cachekey ? sprintf('g.%s.%s', $groupname || '__default', $cachekey) : '';
667 1         3 $self->clean; # Flush errors
668              
669             # Check groupname
670 1 50       4 return WWW::Suffit::AuthDB::Group->new() unless length($groupname); # No group specified
671              
672             # Get cached data
673 1 50       3 my $cached_data = $key ? $self->cache->get($key) : {};
674 1         2 my %data = ();
675 1 50 33     5 if (isnt_void($cached_data) && !$forceupdate) { # Data from cache unless defined $forceupdate
676 0 0       0 %data = isnt_void($cached_data) ? (%$cached_data) : ();
677             } else { # Data from model
678             # Get model
679 1         31 my $model = $self->model;
680              
681             # Get data from model
682 1         5 %data = $model->group_get($groupname);
683 1 50       47 if ($model->error) {
684 0         0 $self->raise(500 => "E1348: %s", $model->error);
685 0         0 return WWW::Suffit::AuthDB::Group->new(error => $self->error);
686             }
687 1 50       13 return WWW::Suffit::AuthDB::Group->new() unless $data{id}; # No group found - empty group data, no errors
688              
689             # Get users list of group
690 1         6 my @grpusr = $model->grpusr_get( groupname => $groupname );
691 1 50       28 if ($model->error) {
692 0         0 $self->raise(500 => "E1357: %s", $model->error);
693 0         0 return WWW::Suffit::AuthDB::Group->new(error => $self->error);
694             }
695 1         8 $data{users} = [sort map {$_->{username}} @grpusr];
  4         10  
696              
697             # Set data from database to cache
698 1 50       4 if ($key) {
699 0         0 $data{is_cached} = 1;
700 0         0 $data{cached} = steady_time();
701 0         0 $data{cachekey} = $cachekey;
702 0         0 $self->cache->set($key, {%data});
703             }
704             }
705              
706             # Return Group instance with %data
707 1         12 return WWW::Suffit::AuthDB::Group->new(%data);
708             }
709             sub realm {
710 1     1 1 1115 my $self = shift;
711 1   50     4 my $realmname = shift // '';
712 1   50     5 my $cachekey = shift // '';
713 1         3 $cachekey =~ s/[^a-z0-9]/?/gi;
714 1   50     4 my $forceupdate = shift || 0;
715 1 50 0     3 my $key = $cachekey ? sprintf('r.%s.%s', $realmname || '__default', $cachekey) : '';
716 1         4 $self->clean; # Flush error
717              
718             # Check realmname
719 1 50       4 return WWW::Suffit::AuthDB::Realm->new() unless length($realmname); # No realm specified
720              
721             # Get cached data
722 1 50       2 my $cached_data = $key ? $self->cache->get($key) : {};
723 1         3 my %data = ();
724 1 50 33     4 if (isnt_void($cached_data) && !$forceupdate) { # Data from cache unless defined $forceupdate
725 0 0       0 %data = isnt_void($cached_data) ? (%$cached_data) : ();
726             } else { # Data from model
727             # Get model
728 1         31 my $model = $self->model;
729              
730             # Get data from model
731 1         5 %data = $model->realm_get($realmname);
732              
733 1 50       35 if ($model->error) {
734 0         0 $self->raise(500 => "E1359: %s", $model->error);
735 0         0 return WWW::Suffit::AuthDB::Realm->new(error => $self->error);
736             }
737 1 50       8 return WWW::Suffit::AuthDB::Realm->new() unless $data{id}; # No realm found - empty realm data, no errors
738              
739             # Get requirements
740 1         5 my @requirements = $model->realm_requirements($realmname);
741 1 50       78 if ($model->error) {
742 0         0 $self->raise(500 => "E1371: %s", $model->error);
743 0         0 return WWW::Suffit::AuthDB::Realm->new(error => $self->error);
744             }
745              
746             # Segregate by provider
747 1         8 my %providers;
748 1         3 foreach my $rec (@requirements) {
749 2 50       6 my $prov = $rec->{provider} or next;
750 2   100     7 my $box = ($providers{$prov} //= []);
751             push @$box, {
752             entity => $rec->{entity} // '',
753             op => lc($rec->{op} // ''),
754 2   50     14 value => $rec->{value} // '',
      50        
      50        
755             };
756             }
757              
758             # Set as requirements
759 1         4 $data{requirements} = {%providers};
760              
761             # Set data from database to cache
762 1 50       9 if ($key) {
763 0         0 $data{is_cached} = 1;
764 0         0 $data{cached} = steady_time();
765 0         0 $data{cachekey} = $cachekey;
766 0         0 $self->cache->set($key, {%data});
767             }
768             }
769              
770             # Return Realm instance with %data
771 1         15 return WWW::Suffit::AuthDB::Realm->new(%data);
772             }
773             sub routes {
774 2     2 1 1088 my $self = shift;
775 2         27 my $url = _url_fix_localhost(shift(@_)); # Base URL (fixed!)
776 2   100     1587 my $cachekey = shift // '';
777 2         7 $cachekey =~ s/[^a-z0-9]/?/gi;
778 2   50     20 my $forceupdate = shift || 0;
779 2 50 0     9 my $key = $cachekey ? sprintf('rts.%s.%s', $url || '__default', $cachekey) : '';
780 2         6 my $now = time;
781 2         10 $self->clean; # Flush error
782              
783             # Get cached data
784 2 50       7 my $cached_data = $key ? $self->cache->get($key) : {};
785             $cached_data = {} if is_hash_ref($cached_data)
786             && is_hash_ref($cached_data->{data})
787 2 50 33     9 && $cached_data->{expires} < $now;
      33        
788              
789 2         52 my %data = ();
790 2 50 33     8 if (isnt_void($cached_data) && !$forceupdate) { # Data from cache unless defined $forceupdate
791 0 0       0 %data = isnt_void($cached_data) ? (%$cached_data) : ();
792             } else { # Data from model
793             # Get model
794 2         83 my $model = $self->model;
795              
796             # Get routes list
797 2         14 my @routes = $model->route_getall;
798 2 50       71 return $self->raise(500 => "E1376: %s", $model->error) if $model->error;
799              
800             # Convert to hash
801 2         19 my $ret = {}; # `id`,`realmname`,`routename`,`method`,`url`,`base`,`path`
802 2         6 foreach my $r (@routes) {
803 0         0 my $base_url_fixed = _url_fix_localhost($r->{base});
804 0 0 0     0 next unless $r->{realmname} && $base_url_fixed eq $url;
805             $ret->{$r->{routename}} = {
806             routename => $r->{routename},
807             realmname => $r->{realmname},
808             method => $r->{method},
809             path => $r->{path},
810 0         0 };
811             }
812              
813             # Set result data hash
814             %data = (
815 2         14 data => $ret,
816             is_cached => 0,
817             cached => 0,
818             expires => 0,
819             cachekey => '',
820             );
821              
822             # Set data from database to cache
823 2 50       7 if ($key) {
824 0         0 $data{is_cached}= 1;
825 0         0 $data{cached} = steady_time();
826 0         0 $data{cachekey} = $cachekey;
827 0   0     0 $data{expires} = $now + ($self->expiration // CACHE_EXPIRES),
828             $self->cache->set($key, {%data});
829             }
830             }
831              
832             # Return data only!
833 2         10 return $data{data};
834             }
835              
836             # Methods that returns cached sub-objects (cached methods)
837             sub cached_user {
838 0     0 1 0 deprecated 'The "WWW::Suffit::AuthDB::cached_user" is deprecated in favor of "user"';
839 0         0 goto &user;
840              
841             # my $self = shift;
842             # my $username = shift // '';
843             # my $cachekey = shift // '';
844             # my $now = time;
845             #
846             # # Get user object from cache by key
847             # $cachekey =~ s/[^a-z0-9]/?/gi;
848             # my $key = $cachekey
849             # ? sprintf('user.%s.%s', $cachekey, $username || '__anonymous')
850             # : sprintf('user.%s', $username // '__anonymous');
851             # #my $upd = $self->meta(sprintf("%s.updated", $key)) // 0;
852             # #my $obj = (($upd + CACHE_EXPIRES) < time) ? $self->cache->get($key) : undef;
853             # my $obj = $self->cache->get($key);
854             # return $obj if $obj && $obj->is_valid; # Return user object from cache if exists
855             #
856             # # Get real object (not cached) otherwise
857             # $obj = $self->user($username);
858             # return $obj if $self->error;
859             #
860             # # Set expires time and marks object as cached
861             # $obj->expires($now + $self->expiration)->mark(steady_time);
862             # $obj->cachekey($cachekey) if $cachekey;
863             # $self->cache->set($key, $obj) if $obj->is_valid;
864             #
865             # # Return object
866             # return $obj;
867             }
868             sub cached_group {
869 0     0 1 0 deprecated 'The "WWW::Suffit::AuthDB::cached_group" is deprecated in favor of "group"';
870 0         0 goto &group;
871              
872             # my $self = shift;
873             # my $groupname = shift // '';
874             # my $cachekey = shift // '';
875             # my $now = time;
876             #
877             # # Get group object from cache by key
878             # $cachekey =~ s/[^a-z0-9]/?/gi;
879             # my $key = $cachekey
880             # ? sprintf('group.%s.%s', $cachekey, $groupname // '__default')
881             # : sprintf('group.%s', $groupname // '__default');
882             # #my $upd = $self->meta(sprintf("%s.updated", $key)) // 0;
883             # #my $obj = (($upd + CACHE_EXPIRES) < time) ? $self->cache->get($key) : undef;
884             # my $obj = $self->cache->get($key);
885             # return $obj if $obj && $obj->is_valid; # Return group object from cache if exists
886             #
887             # # Get real object (not cached) otherwise
888             # $obj = $self->group($groupname);
889             # return $obj if $self->error;
890             #
891             # # Set expires time
892             # $obj->expires($now + $self->expiration)->mark(steady_time);
893             # $obj->cachekey($cachekey) if $cachekey;
894             # $self->cache->set($key, $obj) if $obj->is_valid;
895             #
896             # # Return object
897             # return $obj;
898             }
899             sub cached_realm {
900 0     0 1 0 deprecated 'The "WWW::Suffit::AuthDB::cached_realm" is deprecated in favor of "realm"';
901 0         0 goto &realm;
902              
903             # my $self = shift;
904             # my $realmname = shift // '';
905             # my $cachekey = shift // '';
906             # my $now = time;
907             #
908             # # Get realm object from cache by key
909             # $cachekey =~ s/[^a-z0-9]/?/gi;
910             # my $key = $cachekey
911             # ? sprintf('realm.%s.%s', $cachekey, $realmname // '__default')
912             # : sprintf('realm.%s', $realmname // '__default');
913             # #my $upd = $self->meta(sprintf("%s.updated", $key)) // 0;
914             # #my $obj = (($upd + CACHE_EXPIRES) < time) ? $self->cache->get($key) : undef;
915             # my $obj = $self->cache->get($key);
916             # return $obj if $obj && $obj->is_valid; # Return realm object from cache if exists
917             #
918             # # Get real object (not cached) otherwise
919             # $obj = $self->realm($realmname);
920             # return $obj if $self->error;
921             #
922             # # Set expires time
923             # $obj->expires($now + $self->expiration)->mark(steady_time);
924             # $obj->cachekey($cachekey) if $cachekey;
925             # $self->cache->set($key, $obj) if $obj->is_valid;
926             #
927             # # Return object
928             # return $obj;
929             }
930             sub cached_routes {
931 0     0 1 0 deprecated 'The "WWW::Suffit::AuthDB::cached_routes" is deprecated in favor of "routes"';
932 0         0 goto &routes;
933              
934             # my $self = shift;
935             # my $url = _url_fix_localhost(shift(@_)); # Base URL (fixed!)
936             # my $cachekey = shift // '';
937             # my $now = time;
938             # $self->clean; # Flush error
939             #
940             # # Get from cache
941             # $cachekey =~ s/[^a-z0-9]/?/gi;
942             # my $key = $cachekey
943             # ? sprintf('routes.%s.%s', $cachekey, $url // '__default')
944             # : sprintf('routes.%s', $url // '__default');
945             #
946             # #my $upd = $self->meta(sprintf("%s.updated", $key)) // 0;
947             # #my $val = (($upd + CACHE_EXPIRES) < time) ? $self->cache->get($key) : undef;
948             # my $val = $self->cache->get($key);
949             # return $val->{data} if $val && is_hash_ref($val) && $val->{exp} < $now;
950             #
951             # # Get model
952             # my $model = $self->model;
953             #
954             # # Get routes list
955             # my @routes = $model->route_getall;
956             # return $self->raise(500 => "E1376: %s", $model->error) if $model->error;
957             #
958             # my $ret = {}; # `id`,`realmname`,`routename`,`method`,`url`,`base`,`path`
959             # foreach my $r (@routes) {
960             # my $base_url_fixed = _url_fix_localhost($r->{base});
961             # next unless $r->{realmname} && $base_url_fixed eq $url;
962             # $ret->{$r->{routename}} = {
963             # routename => $r->{routename},
964             # realmname => $r->{realmname},
965             # method => $r->{method},
966             # path => $r->{path},
967             # };
968             # }
969             #
970             # # Set cache record
971             # $self->cache->set($key, {
972             # data => $ret,
973             # exp => $now + $self->expiration,
974             # cached => steady_time,
975             # cachekey => $cachekey,
976             # });
977             #
978             # # Return data only!
979             # return $ret;
980             }
981              
982             sub _url_fix_localhost {
983 2   50 2   22 my $url = shift || DEFAULT_URL;
984 2         45 my $uri = Mojo::URL->new($url);
985 2   50     579 my $host = $uri->host // 'localhost';
986 2 50       27 if ($host =~ /^(((\w+\.)*localhost)|(127\.0\.0\.1)|(ip6-(localhost|loopback))|(\[?\:{2,}1\]?))$/) {
987 2         9 $uri->scheme('http')->host('localhost')->port(undef);
988             }
989 2         38 return $uri->to_string;
990             }
991              
992             1;
993              
994             __END__