App-FargateStack/lib/App/FargateStack/Builder/Utils.pm
package App::FargateStack::Builder::Utils;
use strict;
use warnings;
BEGIN {
use Log::Log4perl;
# this register ths package as a wrapper class helps resolve
# callstack issue when covering Log4perl methods.
Log::Log4perl->wrapper_register(__PACKAGE__);
}
use Carp;
use Data::Dumper;
use Date::Parse qw(str2time);
use English qw(no_match_vars);
use JSON;
use List::Util qw(any none);
use Scalar::Util qw(blessed reftype refaddr looks_like_number);
use Term::ANSIColor;
use Time::Piece;
use Time::HiRes qw(time);
use Text::Diff;
use JSON;
use Role::Tiny;
use parent qw(Exporter Class::Accessor::Fast);
__PACKAGE__->follow_best_practice;
__PACKAGE__->mk_accessors(qw(_var_pool));
our @EXPORT = qw(
ToCamelCase
choose
common_args
confirm
display_diffs
dmp
elapsed_time
jmespath_mapping
log_die
normalize_name
normalize_time_range
normalize_timestamp
toCamelCase
slurp_file
write_json_file
fetch_acm
fetch_cloudtrail
fetch_application_autoscaling
fetch_ecr
fetch_ec2
fetch_ecs
fetch_ecr
fetch_elbv2
fetch_events
fetch_efs
fetch_iam
fetch_logs
fetch_secrets
fetch_sts
fetch_route53
fetch_cli_api
fetch_wafv2
);
########################################################################
sub fetch_application_autoscaling { return shift->fetch_cli_api( 'Application-Autoscaling', @_ ); }
sub fetch_acm { return shift->fetch_cli_api( 'ACM', @_ ); }
sub fetch_cloudtrail { return shift->fetch_cli_api( 'CloudTrail', @_ ); }
sub fetch_iam { return shift->fetch_cli_api( 'IAM', @_ ); }
sub fetch_logs { return shift->fetch_cli_api( 'Logs', @_ ); }
sub fetch_efs { return shift->fetch_cli_api( 'EFS', @_ ); }
sub fetch_ecs { return shift->fetch_cli_api( 'ECS', @_ ); }
sub fetch_ec2 { return shift->fetch_cli_api( 'EC2', @_ ); }
sub fetch_ecr { return shift->fetch_cli_api( 'ECR', @_ ); }
sub fetch_events { return shift->fetch_cli_api( 'Events', @_ ); }
sub fetch_sts { return shift->fetch_cli_api( 'STS', @_ ); }
sub fetch_secrets { return shift->fetch_cli_api( 'Secrets', @_ ); }
sub fetch_elbv2 { return shift->fetch_cli_api( 'ElbV2', @_ ); }
sub fetch_route53 { return shift->fetch_cli_api( 'Route53', @_ ); }
sub fetch_wafv2 { return shift->fetch_cli_api( 'WafV2', @_ ); }
########################################################################
sub fetch_cli_api {
########################################################################
my ( $self, $api, %options ) = @_;
my $class = $self->get( lc $api );
return $class
if $class && !keys %options;
if ( !$class ) {
my $normalized_name = $api;
$normalized_name =~ s/[\-]//xsm;
my $class_path = sprintf 'App/%s.pm', $normalized_name;
require $class_path;
my $class_name = sprintf 'App::%s', $normalized_name;
$self->set( lc $api, $class_name->new( _service_name => lc $api, %{ $self->get_global_options }, %options ) );
$class = $self->get( lc $api );
}
foreach ( keys %options ) {
next if !defined $options{$_};
$class->set( $_, $options{$_} );
}
return $class;
}
########################################################################
sub maybe_color {
########################################################################
my ( $self, $color, $text ) = @_;
return $text
if !$self->get_color;
return colored( $text, $color );
}
########################################################################
sub create_default {
########################################################################
my ( $self, $what, @args ) = @_;
require App::FargateStack::Constants;
croak "no default for $what\n"
if !exists $App::FargateStack::Constants::DEFAULT_NAMES{$what};
my $default = $App::FargateStack::Constants::DEFAULT_NAMES{$what};
return ref $default ? $default->( $self, @args ) : $default;
}
########################################################################
sub confirm {
########################################################################
my ( $prompt, @args ) = @_;
print sprintf "$prompt [y/N] ", @args;
chomp( my $answer = <STDIN> );
return $answer =~ /^y(es)?$/xsmi;
}
########################################################################
sub common_args {
########################################################################
my ( $self, @args ) = @_;
my $config = $self->get_config;
my $var_pool = {
config => $config,
cache => $self->get_cache,
dryrun => $self->get_dryrun,
# these just avoid a bunch of hash digging
tasks => $config->{tasks},
cluster => $config->{cluster},
security_groups => $config->{security_groups},
route53 => $config->{route53},
alb => $config->{alb},
app => $config->{app},
subnets => $config->{subnets},
role => $config->{role},
events_role => $config->{events_role},
};
$self->set__var_pool($var_pool);
return $var_pool
if !@args;
my @invalid_args = grep { !exists $var_pool->{$_} } @args;
croak sprintf "invalid argument(s): %s\n", join q{,}, @invalid_args
if @invalid_args;
return @{$var_pool}{@args};
}
########################################################################
sub display_diffs {
########################################################################
my ( $self, $old, $new, $options ) = @_;
my $json = JSON->new->canonical->pretty->allow_blessed->convert_blessed;
my $old_str = $json->encode($old);
my $new_str = $json->encode($new);
# normalize line endings + ensure trailing newline (helps diff output)
for my $str ( $old_str, $new_str ) {
$str =~ s/\r\n/\n/xsmg;
next if $str =~ /\n\z/xsm;
$str .= "\n";
}
my $style = ( $options && ref $options ) ? ( $options->{style} // 'Table' ) : 'Table';
my $diffs = diff( \$old_str, \$new_str, { STYLE => $style } ) // q{};
return $diffs
if !$options || !ref $options;
return q{} if !length $diffs;
my $log_level = $options->{log_level} // 'error';
my $title = $options->{title} //= 'objects differ:';
$self->get_logger->$log_level( sprintf "\t%s", $title );
$self->get_logger->$log_level( sprintf "\n\t%s", $diffs );
return $diffs;
}
########################################################################
sub ToCamelCase { goto &_toCamelCase; }
sub toCamelCase { return _toCamelCase( $_[0], $_[1], 1 ); }
########################################################################
sub _toCamelCase {
########################################################################
my ( $snake_case, $want_hash, $lc_first ) = @_;
$want_hash //= wantarray ? 0 : 1;
my @CamelCase = map {
( $want_hash ? $_ : (), join q{}, map {ucfirst} split /_/xsm )
} @{$snake_case};
return $want_hash ? {@CamelCase} : @CamelCase
if !$lc_first;
return map {lcfirst} @CamelCase
if !$want_hash;
my %camelCase = @CamelCase;
%camelCase = map { $_ => lcfirst $camelCase{$_} } keys %camelCase;
return \%camelCase;
}
########################################################################
sub jmespath_mapping {
########################################################################
my ( $prefix, $elems, $ucfirst ) = @_;
$ucfirst //= 0;
my $hash_list = reftype($elems) eq 'HASH' ? $elems : $ucfirst ? ToCamelCase($elems) : toCamelCase($elems);
my $list = sprintf '%s.%s', $prefix, encode_json $hash_list;
$list =~ s/"//gxsm;
return $list;
}
########################################################################
sub elapsed_time {
########################################################################
my ($start_time) = @_;
return q{-}
if !$start_time;
# Extract timestamp and offset
my ( $date, $time, $sign, $h_offset, $m_offset ) = $start_time =~ m{
^(\d{4}-\d{2}-\d{2}) # date
T(\d{2}:\d{2}:\d{2}) # time
\.\d+ # fractional seconds
([+-])(\d{2}):(\d{2})$ # offset
}x;
# Parse local time (as in the string, which is relative to its own offset)
my $tp = Time::Piece->strptime( "$date $time", '%Y-%m-%d %H:%M:%S' );
# Calculate total offset in seconds
my $offset_sec = ( $h_offset * 3600 + $m_offset * 60 ) * ( $sign eq '+' ? 1 : -1 );
# Convert to UTC epoch (add offset to local time to get UTC)
my $epoch_utc = $tp->epoch - $offset_sec;
# Get current UTC time
my $now = time;
# Elapsed time in seconds
my $elapsed = int( $now - $epoch_utc );
# Break into minutes and seconds
my $minutes = int( $elapsed / 60 );
my $seconds = $elapsed % 60;
return sprintf '%d:%02d', $minutes, $seconds;
}
########################################################################
sub choose (&) { return $_[0]->(); }
########################################################################
########################################################################
sub dmp { return print {*STDERR} Dumper( [@_] ); }
########################################################################
########################################################################
sub _inc {
########################################################################
my ( $what, $self, $key, $value ) = @_;
my $resources = $self->get($what) // {};
if ( ref $value && reftype($value) eq 'ARRAY' ) {
($value) = @{$value};
$resources->{$key} //= [];
push @{ $resources->{$key} }, $value;
}
else {
$resources->{$key} = $value;
}
$self->set( $what, $resources );
return $resources;
}
########################################################################
sub inc_existing_resources {
########################################################################
return _inc( 'existing_resources', @_ );
}
########################################################################
sub inc_required_resources {
########################################################################
return _inc( 'required_resources', @_ );
}
########################################################################
sub write_json_file {
########################################################################
my ( $self, $file, $obj ) = @_;
open my $fh, '>', $file
or croak "could not open $file for writing\n";
my $json = JSON->new->pretty->encode($obj);
print {$fh} $json;
close $fh;
return $json;
}
########################################################################
sub slurp_file {
########################################################################
my ( $file, $json ) = @_;
local $RS = undef;
open my $fh, '<', $file
or croak "could not open $file\n";
my $content = <$fh>;
close $fh;
return $json ? decode_json($content) : $content;
}
########################################################################
sub section_break { return shift->get_logger->info( q{-} x 80 ) }
########################################################################
########################################################################
sub normalize_name {
########################################################################
my ( $self, $name ) = @_;
return join q{}, map {ucfirst} split /[_-]+/xsm, $name;
}
########################################################################
sub abbrev {
########################################################################
my ( $text, $len, $offset ) = @_;
$offset //= 0;
$text //= q{};
return sprintf '%s...', substr $text, $offset, $len;
}
########################################################################
sub is_service_running {
########################################################################
my ( $self, $task_name ) = @_;
my ( $config, $cluster ) = $self->common_args(qw(config cluster));
my $cluster_name = $cluster->{name};
my $ecs = $self->fetch_ecs;
my $services = $ecs->list_services( $cluster_name, 'serviceArns' );
croak sprintf "ERROR: could not list services for: [%s]\n%s", $cluster_name, $ecs->get_error
if !$services;
return
if none {/\/$task_name/xsm} @{$services};
my $status = $ecs->describe_services(
cluster_name => $cluster_name,
service_name => $task_name,
query => 'services[0].runningCount'
);
croak sprintf "ERROR: could not describe services for: [%s/%s]\n%s", $cluster_name, $task_name, $ecs->get_error
if !defined $status;
return $status;
}
########################################################################
sub _log {
########################################################################
my ( $logger, $level, @args ) = @_;
# If first arg looks like a sprintf format string AND we have more args, call sprintf
if ( @args > 1 && $args[0] =~ /%/xsm ) {
return $logger->$level( sprintf shift(@args), @args );
}
else {
return $logger->$level(@args);
}
}
sub log_info { return _log( shift->get_logger, 'info', @_ ) }
sub log_debug { return _log( shift->get_logger, 'debug', @_ ) }
sub log_warn { return _log( shift->get_logger, 'warn', @_ ) }
sub log_error { return _log( shift->get_logger, 'error', @_ ) }
sub log_die { _log( shift->get_logger, 'error', @_ ); die q{}; }
sub log_trace { return _log( shift->get_logger, 'trace', @_ ) }
sub log_fatal { return _log( shift->get_logger, 'fatal', @_ ) }
########################################################################
sub normalize_timestamp {
########################################################################
my ($ts) = @_;
return
if !$ts;
# Already epoch?
return int $ts if $ts =~ /^\d{10}$/xsm; # seconds
return int $ts / 1000 if $ts =~ /^\d{13}$/xsm; # millis
my $s = "$ts";
# Common cleanups:
$s =~ s/,//xsmg; # "Aug 12, 2025, 4:55:04 PM" -> "Aug 12 2025 4:55:04 PM"
$s =~ s/Z$/+0000/xsm; # ISO8601Z -> explicit offset
$s =~ s/([+\-]\d\d):(\d\d)$/$1$2/xsm; # "+05:30" -> "+0530"
$s =~ s/[.]\d+(?=(?:Z|[+\-]\d\d:?\d\d)$)//xsm; # strip fractional seconds if present
# Some services append " UTC" or similar—strip trailing timezone words
$s =~ s/\s+UTC$//xsmi;
my $epoch = str2time($s);
die "unrecognized timestamp: [$ts]"
if !defined $epoch;
return int $epoch;
}
use Readonly;
Readonly::Scalar our $SEC_PER_MIN => 60;
Readonly::Scalar our $SEC_PER_HOUR => 60 * $SEC_PER_MIN;
Readonly::Scalar our $SEC_PER_DAY => 24 * $SEC_PER_HOUR;
########################################################################
sub normalize_time_range {
########################################################################
my ( $start, $end ) = @_;
return
if !$start;
my $now = time;
my $start_epoch = _to_epoch( $start, $now );
my $end_epoch = defined $end ? _to_epoch( $end, $now ) : undef;
croak 'start is in the future' if $start_epoch > $now;
croak 'end is in the future' if defined $end_epoch && $end_epoch > $now;
croak 'start > end' if defined $end_epoch && $start_epoch > $end_epoch;
return ( $start_epoch * 1000, defined $end_epoch ? $end_epoch * 1000 : undef );
}
########################################################################
sub _to_epoch {
########################################################################
my ( $value, $now ) = @_;
# Duration syntax (e.g. 5d, 30m, 2h)
if ( $value =~ /^(\d+)([dmh])$/xsmi ) {
my ( $n, $unit ) = ( $1, lc $2 );
croak 'duration cannot be zero' if $n == 0;
my %span = (
d => $SEC_PER_DAY,
h => $SEC_PER_HOUR,
m => $SEC_PER_MIN,
);
return $now - $n * $span{$unit};
}
# Date string ‑ let Date::Parse do the heavy lifting
my $epoch = str2time($value);
croak "unrecognized date format: [$value]"
if !defined $epoch;
return $epoch;
}
1;
__END__
=pod
=head1 NAME
App::FargateStack::Builder::Utils
=head1 SYNOPSIS
# can be used as a role with Role::Tiny or you can import methods
with 'App::FargateStack::Builder::Utils';
use App::FargateStack::Builder::Utils qw(choose log_die);
=head1 METHODS AND SUBROUTINES
=head2 choose
A clever little helper that makes your code look awesome. Instead of this:
my $foo;
if ( $bar ) {
$foo = 'biz';
}
else {
$foo = 'baz';
}
my $foo = choose {
return 'biz'
if $bar;
return 'baz';
}
The example above would probably be handled by a ternary, but imagine
more complex logic and you'll see why the assignment and declaration
sometimes get separated. Since I hate to do that...C<choose> was born.
=head2 normalize_timestamp
=head2 fetch_*
Use the C<fetch_*> methods to retrieve an instance of one of the AWS
API classes. The fetch method caches class instances and instantiates
them if necessary by providing common arguments (like profile).
my $ecs = $self->fetch_ecs;
=head2 normalize_time_range
my ($from_ms, $to_ms) = normalize_time_range($start, $end);
Normalizes a human-friendly time range into Unix epoch timestamps in
**milliseconds**.
Given a required C<$start> and an optional C<$end>, this routine parses
each value into epoch seconds (using L<Date::Parse/str2time> for absolute
dates, or a compact “duration” syntax), validates the range, and returns
a two-element list: C<(start_ms, end_ms_or_undef)>.
Returns an empty list if C<$start> is false/undefined (useful for
“no time filter” cases).
=head3 Arguments
=over 4
=item C<$start> (required)
Either:
=over 4
=item * A relative duration: C</^\d+[dmh]$/i>
Examples: C<"5m"> (5 minutes), C<"2h"> (2 hours), C<"7d"> (7 days).
Zero durations (e.g., C<"0m">) are rejected.
=item * An absolute date/time string parsed by C<str2time>.
Examples: C<"2025-08-12 08:00">, C<"2025-08-12T08:00:00Z">, RFC-822 style,
etc. If no timezone is present, parsing uses the local timezone.
=back
=item C<$end> (optional)
Same accepted formats as C<$start>. If omitted, the end of the range is
left undefined.
=back
=head3 Behavior
=over 4
=item * A single “now” is captured at the start of the call, so when both
C<$start> and C<$end> are durations (e.g., C<"15m"> and C<"5m">) they are
evaluated relative to the same instant.
=item * Validation:
=over 4
=item * C<start is in the future> if C<$start> resolves after “now”.
=item * C<end is in the future> if C<$end> resolves after “now”.
=item * C<start > end> if both are defined and C<$start> resolves after C<$end>.
=item * C<duration cannot be zero> for C<0d>, C<0h>, or C<0m>.
=item * C<unrecognized date format: [VALUE]> if C<str2time> cannot parse.
=back
=back
=head3 Returns
A two-element list in **milliseconds since the Unix epoch**:
( $start_ms, $end_ms_or_undef )
B<List context is expected.> In scalar context, Perl will return the last
element of the list (which may be C<undef>); don’t rely on that.
=head3 Examples
# Last 15 minutes, open-ended end:
my ($from, $to) = normalize_time_range('15m'); # $to is undef
# Absolute window (local timezone if none given):
my ($from, $to) = normalize_time_range('2025-08-12 00:00',
'2025-08-12 06:00');
# Mixed: from 2 hours ago to 30 minutes ago:
my ($from, $to) = normalize_time_range('2h', '30m');
=head3 Notes
=over 4
=item * The return values are in milliseconds. Some AWS APIs expect seconds;
divide by 1000 if needed.
=item * Duration units supported are days (C<d>), hours (C<h>), and minutes
(C<m>). Seconds/weeks are not accepted.
=item * Absolute parsing is delegated to L<Date::Parse/str2time>; pass a
timezone (e.g., trailing C<Z>) to avoid local-TZ assumptions.
=back
=pod
=head3 jmespath_mapping
my $expr = jmespath_mapping($prefix, $elems, $ucfirst);
Builds a JMESPath object-projection expression by combining a prefix
(e.g., C<'tasks[]'>) with a field mapping rendered in JMESPath syntax,
such as C<{TaskArn:taskArn,StartedAt:startedAt}>. Quotes are stripped
from the JSON representation to form valid JMESPath.
=head4 Arguments
=over 4
=item * C<$prefix> (Str)
A JMESPath prefix to project over, e.g., C<'tasks[]'> or C<'events[]'>.
=item * C<$elems> (HashRef|ArrayRef)
Either a hashref mapping output keys to source field names, or a list
of source field names. When a list/arrayref is provided, keys are
auto-generated via camel-casing utilities (see C<$ucfirst> below).
Examples:
# HashRef form (used as-is):
{ TaskArn => 'taskArn', StartedAt => 'startedAt' }
# ArrayRef form (auto-mapped):
[ 'taskArn', 'startedAt', 'stoppedAt' ]
=item * C<$ucfirst> (Bool, optional; default 0)
Controls how output keys are generated when C<$elems> is not a hashref.
- If false (default), keys use lower camel case via C<toCamelCase()>.
- If true, keys use upper camel case via C<ToCamelCase()>.
When C<$elems> is a hashref, this flag is ignored.
=back
=head4 Returns
(Str) A JMESPath expression of the form:
"$prefix.{Key1:field1,Key2:field2,...}"
For example:
jmespath_mapping('tasks[]', [ 'taskArn', 'startedAt' ], 1)
=> 'tasks[].{TaskArn:taskArn,StartedAt:startedAt}'
jmespath_mapping('events[]', { Id => 'eventID', Time => 'eventTime' }, 0)
=> 'events[].{Id:eventID,Time:eventTime}'
=head4 Notes
- When C<$elems> is a hashref, it is used directly as the key->field map.
- When C<$elems> is a list/arrayref, the keys are derived from each field
name using C<toCamelCase()> or C<ToCamelCase()> depending on C<$ucfirst>.
- The need to handle both camel case styles exists because AWS services
and JMESPath queries are not consistent in field naming conventions.
Some AWS APIs return structures with lower camel case keys
(e.g., C<taskArn>), while others or UI tools expect upper camel case
(e.g., C<TaskArn>). This helper accommodates both without requiring
the caller to manually reformat keys.
- Internally, the method JSON-encodes the map and then removes double
quotes to yield valid JMESPath object projection syntax.
=head4 See Also
L<JMESPath|https://jmespath.org/> specification for object projections.
=head1 AUTHOR
Rob Lauer - <rlauer@treasurersbriefcase.com>
=head1 SEE ALSO
L<Role::Tiny>
=cut