File Coverage

blib/lib/Weather/NHC/TropicalCyclone/Storm.pm

Criterion	Covered	Total	%
statement	83	145	57.2
branch	9	32	28.1
condition	5	18	27.7
subroutine	25	34	73.5
pod	19	21	90.4
total	141	250	56.4

package Weather::NHC::TropicalCyclone::Storm;

use strict;
use warnings;

use HTTP::Tiny ();
use HTTP::Status qw/:constants/;
use Validate::Tiny    ();
use HTML::TreeBuilder ();

# specify accessors
use Object::Tiny qw/id binNumber name classification intensity pressure latitude longitude latitude_numberic movementDir movementSpeed lastUpdate publicAdvisory forecastAdvisory windSpeedProbabilities forecastDiscussion forecastGraphics forecastTrack windWatchesWarnings trackCone initialWindExtent forecastWindRadiiGIS bestTrackGIS earliestArrivalTimeTSWindsGIS mostLikelyTimeTSWindsGIS windSpeedProbabilitiesGIS kmzFile34kt kmzFile50kt kmzFile64kt stormSurgeWatchWarningGIS potentialStormSurgeFloodingGIS/;

our $DEFAULT_GRAPHICS_ROOT = q{https://www.nhc.noaa.gov/storm_graphics};
our $DEFAULT_BTK_ROOT      = q{https://ftp.nhc.noaa.gov/atcf/btk};
our $CLASSIFICATIONS       = {
    TD  => q{Tropical Depression},
    STD => q{Subtropical Depression},
    TS  => q{Tropical Storm},
    HU  => q{Hurricane},
    STS => q{Subtropical Storm},
    PTC => q{Post-tropical Cyclone / Remnants},
    TY  => q{Typhoon (we don't use this currently)},
    PC  => q{Potential Tropical Cyclone},
};

# constructor
sub new {
    my ( $pkg, $self ) = @_;

    my $v          = Validate::Tiny->new;
    my $validation = $v->check( $self, $pkg->_get_validation_rules );
    if ( not $v->success ) {
        die qq{Field validation errors found creating package instance for: } . join( q{, }, keys %{ $validation->error } ) . qq{\n};
    }

    return bless $self, $pkg;
}

sub _get_validation_rules {
    my $self = shift;
    return {
        fields => [qw/id binNumber name classification/],
        checks => [
            [qw/id binNumber name classification/] => Validate::Tiny::is_required(),
            classification                         => sub {
                my ( $value, $params ) = @_;

                # branch, if true indicates failed validation
                if ( not grep { /$value/ } ( keys %$CLASSIFICATIONS ) ) {
                    return q{Invalid classification, not defined in NHC specification.};
                }

                # indicates successful validation
                return undef;
            },
        ],
    };
}

sub _fetch_text_types {
    my $self = shift;

    # white list of resources and URL attributes they provide
    my $types = {
        text => [qw/publicAdvisory forecastAdvisory forecastDiscussion windSpeedProbabilities/],
    };

    return $types;
}

sub _fetch_data_types {
    my $self = shift;

    # white list of resources and URL attributes they provide
    my $types = {
        zipFile          => [qw/forecastTrack windWatchesWarnings trackCone initialWindExtent forecastWindRadiiGIS bestTrackGIS potentialStormSurgeFloodingGIS/],
        kmzFile          => [qw/forecastTrack windWatchesWarnings trackCone initialWindExtent forecastWindRadiiGIS bestTrackGIS earliestArrivalTimeTSWindsGIS mostLikelyTimeTSWindsGIS/],
        zipFile5km       => [qw/windSpeedProbabilitiesGIS/],
        zipFile0p5deg    => [qw/windSpeedProbabilitiesGIS/],
        kmzFile34kt      => [qw/windSpeedProbabilitiesGIS/],
        kmzFile50kt      => [qw/windSpeedProbabilitiesGIS/],
        kmzFile64kt      => [qw/windSpeedProbabilitiesGIS/],
        kmlFile          => [qw/stormSurgeWatchWarningGIS/],
        zipFileTidalMask => [qw/potentialStormSurgeFloodingGIS/],
    };

    return $types;
}

# get storm classification "real classification"
sub kind {
    my $self = shift;
    die qq{'classification' field not set\n} if not $self->classification;
    die qq{Unknown storm classification\n}   if not $CLASSIFICATIONS->{ $self->classification };
    return $CLASSIFICATIONS->{ $self->classification };
}

# determine basin based on binNumber
sub basin {
    my $self = shift;
    die qq{'binNumber' field not set\n} if not $self->binNumber;

    # allow for easy querying of "basin"
    my $BASINS = {
        atlantic => qr/^AT[1-5]$/i,
        pacific  => qr/^EP[1-5]$/i,
    };
    for my $basin ( keys %$BASINS ) {
        return $basin if $self->binNumber =~ $BASINS->{$basin};
    }
    return undef;
}

# attempts to get base graphics directory, then scrapes
# the index page for the files and returns an array reference
# of all image addresses for this storm
sub fetch_forecastGraphics_urls {
    my $self = shift;

    my $url = $self->forecastGraphics->url;

    my $http = HTTP::Tiny->new;

    my $response = $http->get($url);

    my $html = $response->{content};

    $html =~ m/storm_graphics\/(.+)\/refresh/;
    my $prefix = $1;
    return [] if not $prefix;

    my $base = sprintf( qq{%s/%s}, $DEFAULT_GRAPHICS_ROOT, $prefix );
    $response = $http->get($base);

    $html = $response->{content};
    my $id   = uc $self->id;
    my @imgs = ( $html =~ m/href="($id.+\.png)"/g );
    @imgs = map { qq{$base/$_} } @imgs;

    return \@imgs;
}

# rolls up requesting url and extracting text inside of the
# tag into one subroutine
sub _get_text {
    my ( $self, $resource, $local_file ) = @_;

    # note, accessors like "->advNum" are generated in Weather::NHC::TropicalCyclone using Util::H2O::h2o
    if ( not( $self->$resource->advNum or $self->$resource->issuance or $self->$resource->url ) ) {
        die qq{Resource must be one of: 'publicAdvisory', 'forecastAdvisory', or 'forecastDiscssion'\n};
    }

    my $url = $self->$resource->url;

    my $http = HTTP::Tiny->new;

    my $response = $http->get($url);

    # extract actual advisory text from  and return just that text
    my $htb = HTML::TreeBuilder->new;
    $htb->parse( $response->{content} );

    my $pre = $htb->look_down( '_tag', 'pre' );

    if ($local_file) {
        open my $fh, q{>}, $local_file or die qq{Failed to open '$local_file' for writing: $!\n};
        print $fh $pre->as_text;
        close $fh;
    }

    return ( $pre->as_text, $self->$resource->advNum, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_publicAdvisory {
    my ( $self, $local_file ) = @_;
    return $self->_get_text( q{publicAdvisory}, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_forecastAdvisory {
    my ( $self, $local_file ) = @_;
    return $self->_get_text( q{forecastAdvisory}, $local_file );
}

# in this case, the $local_file is the file to which the ATCF data is saved,
# the forecast advisory is only handled as text; ATCF is returned as an arrary
# ref
sub fetch_forecastAdvisory_as_atcf {
    my ( $self, $local_file ) = @_;
    my ( $text, $advNum, $_ignore ) = $self->_get_text(q{forecastAdvisory});
    require Weather::NHC::TropicalCyclone::ForecastAdvisory;

    my $fst_ref   = Weather::NHC::TropicalCyclone::ForecastAdvisory->new( input_text => $text, output_file => $local_file );
    my $atcf_text = $fst_ref->extract_atcf;

    # save file if $local_file is passed
    if ($local_file) {
        $fst_ref->save_atcf;
    }

    return ( $fst_ref->as_atcf, $advNum, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_forecastDiscussion {
    my ( $self, $local_file ) = @_;
    return $self->_get_text( q{forecastDiscussion}, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_windspeedProbabilities {
    my ( $self, $local_file ) = @_;
    return $self->_get_text( q{windSpeedProbabilities}, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_forecastTrack {
    my ( $self, $type, $local_file ) = @_;
    return $self->_get_file( q{forecastTrack}, $type, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_windWatchesWarnings {
    my ( $self, $type, $local_file ) = @_;
    return $self->_get_file( q{windWatchesWarnings}, $type, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_trackCone {
    my ( $self, $type, $local_file ) = @_;
    return $self->_get_file( q{trackCone}, $type, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_initialWindExtent {
    my ( $self, $type, $local_file ) = @_;
    return $self->_get_file( q{initialWindExtent}, $type, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_forecastWindRadiiGIS {
    my ( $self, $type, $local_file ) = @_;
    return $self->_get_file( q{forecastWindRadiiGIS}, $type, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_bestTrackGIS {
    my ( $self, $type, $local_file ) = @_;
    return $self->_get_file( q{bestTrackGIS}, $type, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_earliestArrivalTimeTSWindsGIS {
    my ( $self, $type, $local_file ) = @_;
    return $self->_get_file( q{earliestArrivalTimeTSWindsGIS}, $type, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_mostLikelyTimeTSWindsGIS {
    my ( $self, $type, $local_file ) = @_;
    return $self->_get_file( q{mostLikelyTimeTSWindsGIS}, $type, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_windSpeedProbabilitiesGIS {
    my ( $self, $type, $local_file ) = @_;
    return $self->_get_file( q{windSpeedProbabilitiesGIS}, $type, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_stormSurgeWatchWarningGIS {
    my ( $self, $type, $local_file ) = @_;
    return $self->_get_file( q{stormSurgeWatchWarningGIS}, $type, $local_file );
}

# optionally provide a local file name to save fetched file to
sub fetch_potentialStormSurgeFloodingGIS {
    my ( $self, $type, $local_file ) = @_;
    return $self->_get_file( q{potentialStormSurgeFloodingGIS}, $type, $local_file );
}

# rolls up requesting file, based on url associated with file key ("url" key is not specified)
sub _get_file {
    my ( $self, $resource, $urlKey, $local_file ) = @_;

    my $types = $self->_fetch_data_types;

    # make sure $urlKey is provided by the resource (defined in $types hash ref above)
    die qq{'$urlKey' is not a valid type provided by '$resource'.\n} if not grep { /$resource/ } ( @{ $types->{$urlKey} } );

    # check to make sure $resource is not 'null'
    return undef if ref $self->$resource ne q{HASH} or not $self->$resource->{$urlKey};

    my $url = $self->$resource->{$urlKey};

    # extract file name from URL if no $local_file is specified
    if ( not $local_file ) {

        # extract file name from the end of the URL
        $url =~ m/\/([a-zA-Z0-9_]+)\.([a-zA-Z]+)$/;
        $local_file = qq{$1.$2};
    }

    my $http = HTTP::Tiny->new;

    my $response = $http->mirror( $url, $local_file );

    if ( not $response->{success} ) {
        my $status = $response->{status} // q{Unknown};
        die qq{Download of $url failed. HTTP status: $status\n};
    }

    # bestTrackGIS resource doesn't provide "advNum" per specification
    # so it doesn't try to deref an method that may not exist
    return ( $local_file, $self->$resource->{advNum} // q{N/A} );
}

# auxillary methods to fetch the best track ".dat" file via NHC's FTP over HTTPS

sub fetch_best_track {
    my ( $self, $local_file ) = @_;

    my $btk_file = sprintf( "b%s.dat", $self->id );
    my $url = sprintf( "%s/%s", $DEFAULT_BTK_ROOT, $btk_file );

    $local_file //= $btk_file;

    my $http = HTTP::Tiny->new;

    my $response = $http->mirror( $url, $local_file );

    if ( not $response->{success} ) {
        my $status = $response->{status} // q{Unknown};
        die qq{Download of $url failed. HTTP status: $status\n};
    }

    # bestTrackGIS resource doesn't provide "advNum" per specification
    return $local_file;
}

1;

__END__