—package
WWW::Suffit::AuthDB;
use
strict;
use
utf8;
=encoding utf8
=head1 NAME
WWW::Suffit::AuthDB - Suffit Authorization Database
=head1 SYNOPSIS
use WWW::Suffit::AuthDB;
my $authdb = WWW::Suffit::AuthDB->new(
);
=head1 DESCRIPTION
Suffit Authorization Database
=head1 ATTRIBUTES
This class implements the following attributes
=head2 cached
cached => 1
cached => 'yes'
cached => 'on'
cached => 'enable'
This attribute performs enabling caching while establishing of connection with database
$authdb = $authdb->cached("On");
my $cached = $authdb->cached;
Default: false (no caching connection)
=head2 initialized
initialized => 1
initialized => 'yes'
initialized => 'on'
initialized => 'enable'
This attribute marks the schema as initialized or performs read this status
=head2 code
code => undef
Read only attribute to get the HTTP code
my $code = $authdb->code; # 200
=head2 data
data => undef
Read only attribute to get the current data pool
my $data = $authdb->data;
=head2 ds, dsuri
Data source URI. See L<WWW::Suffit::AuthDB::Model>
$authdb = $authdb->ds("sqlite:///tmp/auth.db?sqlite_unicode=1");
my $ds = $authdb->ds;
Default: 'sponge://'
=head2 error
error => undef
Read only attribute to get the error message
my $error = $authdb->error;
=head2 expiration
expiration => 300
The expiration time
$authdb = $authdb->expiration(60*5);
my $expiration = $authdb->expiration;
B<NOTE!> This attribute MUST be defined before first calling the cache method
Default: 300 (5 min)
=head2 max_keys
max_keys => 1024
The maximum keys number in cache
$authdb = $authdb->max_keys(1024*10);
my $max_keys = $authdb->max_keys;
B<NOTE!> This attribute MUST be defined before first calling the cache method
Default: 1024*1024 (1`048`576 keys max)
=head2 sourcefile
sourcefile => '/tmp/authdb.json'
Path to the source file in JSON format
$authdb = $authdb->sourcefile("/tmp/authdb.json");
my $sourcefile = $authdb->sourcefile;
Default: none
=head1 METHODS
This class inherits all methods from L<Mojo::Base> and implements the following new ones
=head2 new
my $authdb = WWW::Suffit::AuthDB->new(
sourcefile => "/tmp/authdb.json"
);
die $authdb->error if $authdb->error;
Create new AuthDB object
=head2 cache
my $cache = $authdb->cache;
Get cache instance
=head2 cached_group
my $group = $authdb->cached_group("manager");
my $group = $authdb->cached_group("manager", 'd1b919c1');
This method returns cached data of specified groupname as L<WWW::Suffit::AuthDB::Group> object by cachekey
=head2 cached_realm
my $realm = $authdb->cached_realm("default");
my $realm = $authdb->cached_realm("default", 'd1b919c1');
This method returns cached data of specified realm name as L<WWW::Suffit::AuthDB::Realm> object by cachekey
s
=head2 cached_routes
my $routes = $authdb->cached_routes("http://localhost/");
my $routes = $authdb->cached_routes("http://localhost/", 'd1b919c1');
Returns cached hash of routes by base URL and cachekey optionaly
=head2 cached_user
my $user = $authdb->cached_user("alice");
my $user = $authdb->cached_user("alice", 'd1b919c1');
This method returns cached data of specified username as L<WWW::Suffit::AuthDB::User> object by cachekey
=head2 checksum
my $digest = $authdb->checksum("string", "algorithm");
This method generates checksum for string.
Supported algorithms: MD5 (unsafe), SHA1 (unsafe), SHA224, SHA256, SHA384, SHA512
Default algorithm: SHA256
=head2 clean
$authdb->clean;
Cleans state vars on the AuthDB object and returns it
=head2 connect
$authdb->connect;
$authdb->connect('yes'); # cached connection
This method performs regular or cached connection with database. See also L</cached> attribute
=head2 dump
print $authdb->dump;
Returns JSON dump of loaded authentication database
=head2 group
my $group = $authdb->group("manager");
This method returns data of specified groupname as L<WWW::Suffit::AuthDB::Group> object
=head2 is_connected
$authdb->connect unless $authdb->is_connected
This method checks connection status
=head2 load
$authdb->load("/tmp/authdb.json");
die $authdb->error if $authdb->error;
$authdb->load(); # from `sourcefile`
die $authdb->error if $authdb->error;
This method performs loading file to C<data> pool
=head2 model
my $model = $authdb->model;
Get model L<WWW::Suffit::AuthDB::Model> instance
=head2 raise
return $authdb->raise("Error string");
return $authdb->raise("Error %s", "string");
return $authdb->raise(200 => "Error string");
return $authdb->raise(200 => "Error %s", "string");
Sets error string and returns false status (undef). Also this method can performs sets the HTTP status code
=head2 realm
my $realm = $authdb->realm("default");
This method returns data of specified realm name as L<WWW::Suffit::AuthDB::Realm> object
=head2 save
$authdb->save(); # to `sourcefile`
die $authdb->error if $authdb->error;
Performs flush database to file that was specified in constructor
$authdb->save("/tmp/new-authdb.json");
die $authdb->error if $authdb->error;
Performs flush database to file that specified directly
=head2 user
my $user = $authdb->user("alice");
This method returns data of specified username as L<WWW::Suffit::AuthDB::User> object
=head2 META KEYS
Meta keys define the AuthDB setting parameters
=over 4
=item schema.version
Version of the current schema
=back
=head1 ERROR CODES
List of AuthDB Suffit API error codes
API | HTTP | DESCRIPTION
-------+-------+-------------------------------------------------
E1300 [500] Can't load file. File not found
E1301 [500] Can't load data pool from file
E1302 [500] File did not return a JSON object
E1303 [500] Can't serialize data pool to JSON
E1304 [500] Can't save data pool to file
E1305 [500] Can't connect to database (model)
E1306 [500] Connection failed
E1307 [500] The authorization database is not initialized
E1308 [---] Reserved
E1309 [---] Reserved
E1310 [ * ] User not found
E1311 [ * ] Incorrect username stored
E1312 [ * ] Incorrect password stored
E1313 [ * ] The user data is expired
E1314 [ * ] Group not found
E1315 [ * ] Incorrect groupname stored
E1316 [ * ] The group data is expired
E1317 [403] External requests is blocked
E1318 [403] Internal requests is blocked
E1319 [403] Access denied
E1320 [400] No username specified
E1321 [413] The username is too long (1-256 chars required)
E1322 [400] No password specified
E1323 [413] The password is too long (1-256 chars required)
E1324 [403] Account frozen for 5 min
E1325 [501] Incorrect digest algorithm
E1326 [401] Incorrect username or password
E1327 [403] User is disabled
E1328 [---] Reserved
E1329 [500] Database request error (meta_get)
E1330 [400] No key specified
E1331 [500] Database request error (meta_set)
E1332 [400] Incorrect digest algorithm
E1333 [500] Database request error (user_get)
E1334 [400] User already exists
E1335 [500] Database request error (user_add)
E1336 [400] User not found
E1337 [500] Database request error (user_edit)
E1338 [500] Database request error (user_getall)
E1339 [500] Database request error (meta_del)
E1340 [500] Database request error (user_del)
E1341 [500] Database request error (grpusr_del)
E1342 [500] Database request error (user_search)
E1343 [500] Database request error (user_groups)
E1344 [400] No password specified
E1345 [500] Database request error (user_passwd)
E1346 [500] Database request error (user_setkeys)
E1347 [500] Database request error (user_tokens)
E1348 [500] Database request error (group_get)
E1349 [400] Group already exists
E1350 [500] Database request error (group_add)
E1351 [500] Database request error (user_set)
E1352 [500] Database request error (grpusr_add)
E1353 [500] Database request error (group_set)
E1354 [---] Reserved
E1355 [500] Database request error (group_getall)
E1356 [500] Database request error (group_del)
E1357 [500] Database request error (grpusr_get)
E1358 [500] Database request error (group_members)
E1359 [500] Database request error (realm_get)
E1360 [400] Realm already exists
E1361 [500] Database request error (realm_add)
E1362 [500] Database request error (route_release)
E1363 [500] Database request error (route_assign)
E1364 [500] Database request error (realm_requirement_del)
E1365 [500] Database request error (realm_requirement_add)
E1366 [500] Database request error (realm_set)
E1367 [500] Database request error (realm_getall)
E1368 [500] Database request error (realm_del)
E1369 [500] Database request error (token_add)
E1370 [500] Database request error (route_add)
E1371 [500] Database request error (realm_requirements)
E1372 [500] Database request error (realm_routes)
E1373 [500] Database request error (route_get)
E1374 [400] Route already exists
E1375 [500] Database request error (route_set)
E1376 [500] Database request error (route_getall)
E1377 [500] Database request error (route_del)
E1378 [500] Database request error (route_search)
E1379 [500] Database request error (token_del)
E1380 [500] Database request error (token_get)
E1381 [500] Database request error (token_get_cond)
E1382 [500] Database request error (token_set)
E1383 [500] Database request error (token_getall)
E1384 [500] Database request error (stat_get)
E1385 [500] Database request error (stat_set)
B<*> -- this code will be defined later on the interface side
See also list of common Suffit API error codes in L<WWW::Suffit::API/"ERROR CODES">
=head1 EXAMPLE
Example of default authdb.json
See C<src/authdb.json>
=head1 HISTORY
See C<Changes> file
=head1 TO DO
See C<TODO> file
=head1 SEE ALSO
L<WWW::Suffit>, L<Mojolicious>
=head1 AUTHOR
Serż Minus (Sergey Lepenkov) L<https://www.serzik.com> E<lt>abalama@cpan.orgE<gt>
=head1 COPYRIGHT
Copyright (C) 1998-2025 D&D Corporation. All Rights Reserved
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See C<LICENSE> file and L<https://dev.perl.org/licenses/>
=cut
our
$VERSION
=
'1.02'
;
use
Mojo::Base -base;
use
Mojo::URL;
use
WWW::Suffit::Cache;
use
constant {
DEFAULT_ALGORITHM
=>
'SHA256'
,
MAX_CACHE_KEYS
=> 1024*1024,
# 1`048`576 keys max
CACHE_EXPIRES
=> 60*5,
# 5min
};
has
data
=>
''
;
has
error
=>
''
;
has
code
=> 200;
has
sourcefile
=>
''
;
# JSON source file
has
ds
=>
''
;
# Data Source URI
has
dsuri
=>
''
;
# Data Source URI (= ds)
has
max_keys
=> MAX_CACHE_KEYS;
has
expiration
=> CACHE_EXPIRES;
has
cached
=> 0;
has
initialized
=> 0;
sub
raise {
my
$self
=
shift
(
@_
);
return
undef
unless
scalar
(
@_
);
if
(
@_
== 1) {
# "message"
$self
->error(
shift
(
@_
));
}
else
{
# ("code", "message") || ("code", "format", "message") || ("format", "message")
my
$code_or_format
=
shift
@_
;
# Get fisrt arg
if
(is_integer(
$code_or_format
)) {
# first is "code"
$self
->code(
$code_or_format
);
if
(
@_
== 1) {
# second is "message"
$self
->error(
shift
(
@_
));
}
else
{
# "format", "message", ...
$self
->error(
sprintf
(
shift
(
@_
),
@_
));
}
}
else
{
# first is "format"
$self
->error(
sprintf
(
$code_or_format
,
@_
));
}
}
return
undef
;
}
sub
clean {
my
$self
=
shift
;
# Flush session variables
$self
->error(
''
);
$self
->code(200);
return
$self
;
}
sub
cache {
my
$self
=
shift
;
$self
->{cache} ||= WWW::Suffit::Cache->new(
max_keys
=>
$self
->max_keys,
expiration
=>
$self
->expiration,
);
return
$self
->{cache};
}
sub
model {
my
$self
=
shift
;
$self
->{model} ||= WWW::Suffit::AuthDB::Model->new(
$self
->dsuri ||
$self
->ds);
return
$self
->{model};
}
sub
dump
{
my
$self
=
shift
;
to_json(
$self
->{data});
}
sub
load {
my
$self
=
shift
;
my
$file
=
shift
;
$self
->clean;
# Flush error first
if
(
$file
) {
$self
->sourcefile(
$file
)
unless
$self
->sourcefile;
}
else
{
$file
=
$self
->sourcefile;
}
return
$self
unless
$file
;
$self
->raise(
500
=>
"E1300: Can't load file \"$file\". File not found"
) &&
return
$self
unless
-e
$file
;
# Load data pool from file
my
$file_path
= path(
$file
);
my
$cont
= decode(
'UTF-8'
,
$file_path
->slurp) //
''
;
if
(
length
(
$cont
)) {
my
$data
=
eval
{ from_json(
$cont
) };
if
($@) {
$self
->raise(
500
=>
"E1301: Can't load data pool from file \"%s\": %s"
,
$file
, $@);
}
elsif
(
ref
(
$data
) ne
'HASH'
) {
$self
->raise(
500
=>
"E1302: File \"%s\" did not return a JSON object"
,
$file
);
}
else
{
$self
->{data} =
$data
;
}
}
return
$self
;
}
sub
save {
my
$self
=
shift
;
my
$file
=
shift
||
$self
->sourcefile;
$self
->clean;
# Flush error first
return
$self
unless
$file
;
# Save data pool to file
my
$json
=
eval
{ to_json(
$self
->{data}) };
if
($@) {
$self
->raise(
500
=>
"E1303: Can't serialize data pool to JSON: %s"
, $@);
return
$self
;
}
path(
$file
)->spew(encode(
'UTF-8'
,
$json
));
$self
->raise(
500
=>
"E1304: Can't save data pool to file \"%s\": %s"
,
$file
, ($! // 'unknown error'))
unless
-e
$file
;
return
$self
;
}
sub
connect
{
my
$self
=
shift
;
$self
->clean;
# Flush error first
# Connect
my
$cached
= is_true_flag(
shift
//
$self
->cached);
my
$model
=
$self
->model;
if
(
$cached
) {
$model
->connect_cached;
}
else
{
$model
->
connect
unless
$model
->dbh &&
$model
->ping;
}
if
(
$model
->error) {
$self
->raise(
500
=>
"E1305: %s"
,
$model
->error);
return
$self
;
}
elsif
(!
$model
->ping) {
$self
->raise(
500
=>
"E1306: %s"
,
"Connection failed"
);
return
$self
;
}
# Check initialize status
unless
(is_true_flag(
$self
->initialized)) {
# if NOT initialized
if
(
$model
->is_initialized) {
$self
->initialized(1);
# On
}
else
{
# The authorization database is not inialized
$self
->raise(
500
=>
"E1307: %s"
,
$model
->error)
if
$model
->error;
}
}
return
$self
;
}
sub
is_connected {
my
$self
=
shift
;
my
$model
=
$self
->model;
return
0
unless
$model
;
return
1
if
$model
->dbh;
return
0;
}
sub
checksum {
my
$self
=
shift
;
my
$str
=
shift
//
''
;
my
$alg
=
uc
(
shift
// DEFAULT_ALGORITHM);
return
''
unless
length
$str
;
my
$enc_str
= encode(
'UTF-8'
,
$str
);
my
$h
=
''
;
if
(
$alg
eq
'MD5'
) {
$h
= md5_sum(
$enc_str
) }
elsif
(
$alg
eq
'SHA1'
) {
$h
= sha1_hex(
$enc_str
) }
elsif
(
$alg
eq
'SHA224'
) {
$h
= sha224_hex(
$enc_str
) }
elsif
(
$alg
eq
'SHA256'
) {
$h
= sha256_hex(
$enc_str
) }
elsif
(
$alg
eq
'SHA384'
) {
$h
= sha384_hex(
$enc_str
) }
elsif
(
$alg
eq
'SHA512'
) {
$h
= sha512_hex(
$enc_str
) }
return
$h
;
}
# Methods that returns sub-objects
sub
user {
my
$self
=
shift
;
my
$username
=
shift
//
''
;
$self
->clean;
# Flush error
# Check username
return
WWW::Suffit::AuthDB::User->new()
unless
length
(
$username
);
# No user specified
# Get model
my
$model
=
$self
->model;
# Get data from model
my
%data
=
$model
->user_get(
$username
);
if
(
$model
->error) {
$self
->raise(
500
=>
"E1333: %s"
,
$model
->error);
return
WWW::Suffit::AuthDB::User->new(
error
=>
$self
->error);
}
return
WWW::Suffit::AuthDB::User->new()
unless
$data
{id};
# No user found - empty user data, no errors
# Get groups list of user
my
@grpusr
=
$model
->grpusr_get(
username
=>
$username
);
#print STDERR Mojo::Util::dumper({ username => $username, groups => \@grpusr});
if
(
$model
->error) {
$self
->raise(
500
=>
"E1357: %s"
,
$model
->error);
return
WWW::Suffit::AuthDB::User->new(
error
=>
$self
->error);
}
$data
{groups} = [
sort
map
{
$_
->{groupname}}
@grpusr
];
return
WWW::Suffit::AuthDB::User->new(
%data
);
}
sub
group {
my
$self
=
shift
;
my
$groupname
=
shift
//
''
;
$self
->clean;
# Flush error
# Check username
return
WWW::Suffit::AuthDB::Group->new()
unless
length
(
$groupname
);
# No user specified
# Get model
my
$model
=
$self
->model;
# Get data from model
my
%data
=
$model
->group_get(
$groupname
);
if
(
$model
->error) {
$self
->raise(
500
=>
"E1348: %s"
,
$model
->error);
return
WWW::Suffit::AuthDB::Group->new(
error
=>
$self
->error);
}
return
WWW::Suffit::AuthDB::Group->new()
unless
$data
{id};
# No group found - empty group data, no errors
# Get users list of group
my
@grpusr
=
$model
->grpusr_get(
groupname
=>
$groupname
);
if
(
$model
->error) {
$self
->raise(
500
=>
"E1357: %s"
,
$model
->error);
return
WWW::Suffit::AuthDB::Group->new(
error
=>
$self
->error);
}
$data
{users} = [
sort
map
{
$_
->{username}}
@grpusr
];
return
WWW::Suffit::AuthDB::Group->new(
%data
);
}
sub
realm {
my
$self
=
shift
;
my
$realmname
=
shift
//
''
;
$self
->clean;
# Flush error
# Check realmname
return
WWW::Suffit::AuthDB::Realm->new()
unless
length
(
$realmname
);
# No realm specified
# Get model
my
$model
=
$self
->model;
# Get data from model
my
%data
=
$model
->realm_get(
$realmname
);
if
(
$model
->error) {
$self
->raise(
500
=>
"E1359: %s"
,
$model
->error);
return
WWW::Suffit::AuthDB::Realm->new(
error
=>
$self
->error);
}
return
WWW::Suffit::AuthDB::Realm->new()
unless
$data
{id};
# No realm found - empty group data, no errors
# Get requirements
my
@requirements
=
$model
->realm_requirements(
$realmname
);
if
(
$model
->error) {
$self
->raise(
500
=>
"E1371: %s"
,
$model
->error);
return
WWW::Suffit::AuthDB::Realm->new(
error
=>
$self
->error);
}
# Segregate by provider
my
%providers
;
foreach
my
$rec
(
@requirements
) {
my
$prov
=
$rec
->{provider} or
next
;
my
$box
= (
$providers
{
$prov
} //= []);
push
@$box
, {
entity
=>
$rec
->{entity} //
''
,
op
=>
lc
(
$rec
->{op} //
''
),
value
=>
$rec
->{value} //
''
,
};
}
# Set as requirements
$data
{requirements} = {
%providers
};
return
WWW::Suffit::AuthDB::Realm->new(
%data
);
}
# Methods that returns cached sub-objects (cached methods)
sub
cached_user {
my
$self
=
shift
;
my
$username
=
shift
//
''
;
my
$cachekey
=
shift
//
''
;
my
$now
=
time
;
# Get user object from cache by key
$cachekey
=~ s/[^a-z0-9]/?/gi;
my
$key
=
$cachekey
?
sprintf
(
'user.%s.%s'
,
$cachekey
,
$username
||
'__anonymous'
)
:
sprintf
(
'user.%s'
,
$username
//
'__anonymous'
);
#my $upd = $self->meta(sprintf("%s.updated", $key)) // 0;
#my $obj = (($upd + CACHE_EXPIRES) < time) ? $self->cache->get($key) : undef;
my
$obj
=
$self
->cache->get(
$key
);
return
$obj
if
$obj
&&
$obj
->is_valid;
# Return user object from cache if exists
# Get real object (not cached) otherwise
$obj
=
$self
->user(
$username
);
return
$obj
if
$self
->error;
# Set expires time and marks object as cached
$obj
->expires(
$now
+
$self
->expiration)->mark(steady_time);
$obj
->cachekey(
$cachekey
)
if
$cachekey
;
$self
->cache->set(
$key
,
$obj
)
if
$obj
->is_valid;
# Return object
return
$obj
;
}
sub
cached_group {
my
$self
=
shift
;
my
$groupname
=
shift
//
''
;
my
$cachekey
=
shift
//
''
;
my
$now
=
time
;
# Get group object from cache by key
$cachekey
=~ s/[^a-z0-9]/?/gi;
my
$key
=
$cachekey
?
sprintf
(
'group.%s.%s'
,
$cachekey
,
$groupname
//
'__default'
)
:
sprintf
(
'group.%s'
,
$groupname
//
'__default'
);
#my $upd = $self->meta(sprintf("%s.updated", $key)) // 0;
#my $obj = (($upd + CACHE_EXPIRES) < time) ? $self->cache->get($key) : undef;
my
$obj
=
$self
->cache->get(
$key
);
return
$obj
if
$obj
&&
$obj
->is_valid;
# Return group object from cache if exists
# Get real object (not cached) otherwise
$obj
=
$self
->group(
$groupname
);
return
$obj
if
$self
->error;
# Set expires time
$obj
->expires(
$now
+
$self
->expiration)->mark(steady_time);
$obj
->cachekey(
$cachekey
)
if
$cachekey
;
$self
->cache->set(
$key
,
$obj
)
if
$obj
->is_valid;
# Return object
return
$obj
;
}
sub
cached_realm {
my
$self
=
shift
;
my
$realmname
=
shift
//
''
;
my
$cachekey
=
shift
//
''
;
my
$now
=
time
;
# Get realm object from cache by key
$cachekey
=~ s/[^a-z0-9]/?/gi;
my
$key
=
$cachekey
?
sprintf
(
'realm.%s.%s'
,
$cachekey
,
$realmname
//
'__default'
)
:
sprintf
(
'realm.%s'
,
$realmname
//
'__default'
);
#my $upd = $self->meta(sprintf("%s.updated", $key)) // 0;
#my $obj = (($upd + CACHE_EXPIRES) < time) ? $self->cache->get($key) : undef;
my
$obj
=
$self
->cache->get(
$key
);
return
$obj
if
$obj
&&
$obj
->is_valid;
# Return realm object from cache if exists
# Get real object (not cached) otherwise
$obj
=
$self
->realm(
$realmname
);
return
$obj
if
$self
->error;
# Set expires time
$obj
->expires(
$now
+
$self
->expiration)->mark(steady_time);
$obj
->cachekey(
$cachekey
)
if
$cachekey
;
$self
->cache->set(
$key
,
$obj
)
if
$obj
->is_valid;
# Return object
return
$obj
;
}
sub
cached_routes {
my
$self
=
shift
;
my
$url
= _url_fix_localhost(
shift
(
@_
));
# Base URL (fixed!)
my
$cachekey
=
shift
//
''
;
my
$now
=
time
;
$self
->clean;
# Flush error
# Get from cache
$cachekey
=~ s/[^a-z0-9]/?/gi;
my
$key
=
$cachekey
?
sprintf
(
'routes.%s.%s'
,
$cachekey
,
$url
//
'__default'
)
:
sprintf
(
'routes.%s'
,
$url
//
'__default'
);
#my $upd = $self->meta(sprintf("%s.updated", $key)) // 0;
#my $val = (($upd + CACHE_EXPIRES) < time) ? $self->cache->get($key) : undef;
my
$val
=
$self
->cache->get(
$key
);
return
$val
->{data}
if
$val
&& is_hash_ref(
$val
) &&
$val
->{
exp
} <
$now
;
# Get model
my
$model
=
$self
->model;
# Get routes list
my
@routes
=
$model
->route_getall;
return
$self
->raise(
500
=>
"E1376: %s"
,
$model
->error)
if
$model
->error;
my
$ret
= {};
# `id`,`realmname`,`routename`,`method`,`url`,`base`,`path`
foreach
my
$r
(
@routes
) {
my
$base_url_fixed
= _url_fix_localhost(
$r
->{base});
next
unless
$r
->{realmname} &&
$base_url_fixed
eq
$url
;
$ret
->{
$r
->{routename}} = {
routename
=>
$r
->{routename},
realmname
=>
$r
->{realmname},
method
=>
$r
->{method},
path
=>
$r
->{path},
};
}
# Set cache record
$self
->cache->set(
$key
, {
data
=>
$ret
,
exp
=>
$now
+
$self
->expiration,
cached
=> steady_time,
cachekey
=>
$cachekey
,
});
# Return data only!
return
$ret
;
}
sub
_url_fix_localhost {
my
$url
=
shift
|| DEFAULT_URL;
my
$uri
= Mojo::URL->new(
$url
);
my
$host
=
$uri
->host //
'localhost'
;
if
(
$host
=~ /^(((\w+\.)
*localhost
)|(127\.0\.0\.1)|(ip6-(localhost|loopback))|(\[?\:{2,}1\]?))$/) {
$uri
->scheme(
'http'
)->host(
'localhost'
)->port(
undef
);
}
return
$uri
->to_string;
}
1;
__END__