view release on metacpan or  search on metacpan

lib/Astro/SpaceTrack.pm  view on Meta::CPAN

{
    my %valid_format = map { $_ => 1 } qw{ TLE 3LE 2LE XML KVN JSON CSV };

    sub _celestrak_validate_format {
	my ( $self, $format ) = @_;
	$format = defined $format ? uc( $format ) : 'TLE';
	$valid_format{$format}
	    or return HTTP::Response->new(
	    HTTP_PRECONDITION_FAILED,
	    "Format '$format' is not valid" );
	$format eq 'JSON'
	    and $self->getv( 'pretty' )
	    and $format = 'JSON-PRETTY';
	return $format;
    }
}

sub _celestrak_validate_query {
    my ( undef, $query, $name, $valid, $dflt ) = @_;
    $query = defined $query ? uc( $query ) :
	$name =~ m/ \A [0-9]+ \z /smx ? 'CATNR' :
	$name =~ m/ \A [0-9]{4}-[0-9]+ \z /smx ? 'INTDES' :
	defined $dflt ? uc( $dflt ) : $dflt;
    defined $query
	or return $query;
    $valid->{$query}
	or return HTTP::Response->new(
	HTTP_PRECONDITION_FAILED,
	"Query '$query' is not valid" );
    return $query;
}

sub _celestrak_repack_iridium {
    my ( $resp ) = @_;
    local $_ = $resp->content();
    s/ \s+ [[] . []] [ \t]* (?= \r? \n | \z ) //smxg;
    $resp->content( $_ );
    return;
}

{	# Local symbol block.

    my %valid_type = map { $_ => 1 }
	qw{ text/plain text/text application/json application/xml };

    sub _celestrak_response_check {
	my ($self, $resp, $source, $name, @args) = @_;

	# As of 2023-10-17, celestrak( 'fubar' ) gives 200 OK, with
	# content
	# Invalid query: "GROUP=fubar&FORMAT=TLE" (GROUP=fubar not found)

	unless ( $resp->is_success() ) {
	    $resp->code == HTTP_NOT_FOUND
		and return $self->_no_such_catalog(
		$source => $name, @args);
	    return $resp;
	}

	my $content = $resp->decoded_content();

	if ( $content =~ m/ \A Invalid \s+ query: /smx ) {
	    $content =~ m/ \b (?: GROUP | FILE ) =\Q$name\E \s not \s found \b /smx
		and return $self->_no_such_catalog(
		$source => $name, @args);
	    $resp->code( HTTP_BAD_REQUEST );
	    $resp->message( HTTP::Status::status_message(
		    HTTP_BAD_REQUEST ) );
	    return $resp;
	}

	if (my $loc = $resp->header('Content-Location')) {
	    if ($loc =~ m/ redirect [.] htm [?] ( \d{3} ) ; /smx) {
		my $msg = "redirected $1";
		@args and $msg = "@args; $msg";
		$1 == HTTP_NOT_FOUND
		    and return $self->_no_such_catalog(
		    $source => $name, $msg);
		return HTTP::Response->new (+$1, "$msg\n")
	    }
	}
	my $type = lc $resp->header('Content-Type')
	    or do {
	    my $msg = 'No Content-Type header found';
	    @args and $msg = "@args; $msg";
	    return $self->_no_such_catalog(
		$source => $name, $msg);
	};
	foreach my $type ( _trim( split ',', $type ) ) {
	    $type =~ s/ ; .* //smx;
	    $valid_type{$type}
		or next;
	    local $_ = $resp->decoded_content();
	    # As of February 12 2022 Celestrak does this
	    # As of July 23 2022 this is not at the beginning of the
	    # string
	    m/^No GP data found\b/sm
		and last;
	    # As of July 25 2022 Celestrak does this.
	    m/^(?:GROUP|FILE) "[^"]+" does not exist/sm
		and last;
	    return;
	}
	my $msg = "Content-Type: $type";
	@args and $msg = "@args; $msg";
	return $self->_no_such_catalog(
	    $source => $name, $msg);
    }

}	# End local symbol block.

=item $bool = $st->cache_hit( $resp );

This method takes the given HTTP::Response object and returns the cache
hit indicator specified by the 'Pragma: spacetrack-cache-hit =' header.
This will be true if the response came from cache, false if it did not,
and C<undef> if cache was not available.

If the response object is not provided, it returns the data type
from the last method call that returned an HTTP::Response object.

=cut

sub cache_hit {
    $_[2] = 'spacetrack-cache-hit';
    goto &_get_pragma_value;
}

=item $source = $st->content_source($resp);

This method takes the given HTTP::Response object and returns the data
source specified by the 'Pragma: spacetrack-source =' header. What
values you can expect depend on the content_type (see below) as follows:

If the C<content_type()> method returns C<'box_score'>, you can expect
a content-source value of C<'spacetrack'>.

If the content_type method returns C<'iridium-status'>, you can expect
content_source values of C<'kelso'>, C<'mccants'>, or C<'sladen'>,
corresponding to the main source of the data.

If the content_type method returns C<'molczan'>, you can expect a
content_source value of C<'mccants'>.

If the C<content_type()> method returns C<'orbit'>, you can expect
content-source values of C<'amsat'>, C<'celestrak'>, C<'mccants'>,
or C<'spacetrack'>, corresponding to the actual source
of the TLE data.

If the content_type method returns C<'quicksat'>, you can expect a
content_source value of C<'mccants'>.

If the C<content_type()> method returns C<'search'>, you can expect a

lib/Astro/SpaceTrack.pm  view on Meta::CPAN

	$resp->content( $encode{$format}->( $json, $data ) );

	return $resp;
    }

}


####
#
#	Private methods.
#

#	$self->_add_pragmata ($resp, $name => $value, ...);
#
#	This method adds pragma headers to the given HTTP::Response
#	object, of the form pragma => "$name = $value". The pragmata are
#	also cached in $self.
#
#	Pragmata names are normalized by converting them to lower case
#	and converting underscores to dashes.

sub _add_pragmata {
    my ($self, $resp, @args) = @_;
    while (@args) {
	my ( $name, $value ) = splice @args, 0, 2;
	$name = lc $name;
	$name =~ s/ _ /-/smxg;
	$self->{_pragmata}{$name} = $value;
	$resp->push_header(pragma => "$name = $value");
    }
    return;
}

{
    my %format_map = qw{
	3le	tle
    };

    # $accumulator = _accumulator_for( $format, \%opt )
    #
    # This subroutine manufactires and returns an accumulator for the
    # named format. The reference to the options hash is itself
    # optional. The supported options are:
    #   file => true if the data contains a FILE key and the caller
    #		requests that a _file_of_record key be generated if
    #		possible and appropriate. Individual accumulators are at
    #		liberty to ignore this.
    #	pretty => true if the caller requests that the returned data be
    #		nicely formatted. This normally comes from the 'pretty'
    #		attribute. Individual accumulators are at liberty to
    #		ignore this.
    #
    # The return is a code reference. This reference is intended to be
    # called as
    #	$accumulator->( $self, $resp )
    # for each successful HTTP response. After all responses have been
    # processed, the accumulated data are retrieved using
    #  ( $content, $data ) = $accumulator( $self )
    # The first return is the text representation of the accumulated
    # data. The second is the decoded data, and is returned at the
    # accumulator's option. In scalar context only $content is returned.

    sub _accumulator_for {
	my ( $format, $opt ) = @_;
	my $name = $format_map{$format} || $format;
	my $accumulator = __PACKAGE__->can( "_accumulate_${name}_data" )
	    || \&_accumulate_unknown_data;
	my $returner = __PACKAGE__->can( "_accumulate_${name}_return" )
	|| sub {
	    my ( undef, $context ) = @_;
	    return $context->{data};
	};
	my $context = {
	    format	=> $format,
	    opt		=> $opt || {},
	};
	return sub {
	    my ( $self, $resp ) = @_;
	    defined $resp
		or return $returner->( $self, $context );
	    my $content = $resp->content();
	    defined $content
		and $content ne ''
		or return;
	    my $data = $accumulator->( $self, $content, $context );
	    $context->{opt}{file}
		and $data
		and _accumulate_file_of_record( $self, $context, $data );
	    return;
	}
    }

}

sub _accumulate_file_of_record {
    my ( undef, $context, $data ) = @_;		# Invocant unused
    if ( defined $context->{file} ) {
	foreach my $datum ( @{ $data } ) {
	    defined $datum->{FILE}
		and $datum->{FILE} > $context->{file}
		and $datum->{_file_of_record} = $context->{file};
	}
    } else {
	$context->{file} = List::Util::max( -1,
	    map { $_->{FILE} }
	    grep { defined $_->{FILE} }
	    @{ $data }
	);
    }
    return;
}

# The data accumulators. The conventions which must be followed are
# that, given a format named 'fmt':
#
# 1) There MUST be an accumulator named _accumulate_fmt_data(). Its
#    arguments are the invocant, the content of the return, and the
#    context hash. It must accumulate data in $context->{data}, in any
#    format it likes.
# 2) If _accumulate_fmt_data() decodes the data, it SHOULD return a
#    reference to the decoded array. Otherwise it MUST return nothing.
# 3) There MAY be a returner named _accumulate_fmt_return(). If it
#    exists its arguments are the invocant and the context hash. It MUST
#    return a valid representation of the accumulated data in the
#    desired format.
# 4) If _accumulate_fmt_return() does not exist, the return will be the
#    contents of $context->{data}, which MUST have been maintained by
#    _accumulate_fmt_data() as a valid representation of the data in the
#    desired format.
# 5) Note that if _accumulate_fmt_return() exists,
#    _accumulate_fmt_data need not maintain $context->{data} as a valid
#    representation of the accumulated data.

# Accessed via __PACKAGE__->can( "accumulate_${name}_data" ) in
# _accumulator_for(), above
sub _accumulate_csv_data {	## no critic (ProhibitUnusedPrivateSubroutines)
    my ( undef, $content, $context ) = @_;	# Invocant unused
    if ( defined $context->{data} ) {
	$context->{data} =~ s{ (?<! \n ) \z }{\n}smx;
	$content =~ s{ .* \n }{}smx;
	$context->{data} .= $content;
    } else {
	$context->{data} = $content;
    }
    return;
}

# Accessed via __PACKAGE__->can( "accumulate_${name}_data" ) in
# _accumulator_for(), above
sub _accumulate_html_data {	## no critic (ProhibitUnusedPrivateSubroutines)
    my ( undef, $content, $context ) = @_;	# Invocant unused
    if ( defined $context->{data} ) {
	$context->{data} =~ s{ \s* </tbody> \s* </table> \s* \z }{}smx;
	$content =~ s{ .* <tbody> \s* }{}smx;
	$context->{data} .= $content;
    } else {
	$context->{data} = $content;
    }
    return;
}

# Accessed via __PACKAGE__->can( "accumulate_${name}_data" ) in
# _accumulator_for(), above
sub _accumulate_json_data {	## no critic (ProhibitUnusedPrivateSubroutines)
    my ( $self, $content, $context ) = @_;

    my $json = $context->{json} ||= $self->_get_json_object(
	pretty => $context->{opt}{pretty},
    );

    my $data = $json->decode( $content );

    ARRAY_REF eq ref $data
	or $data = [ $data ];

    @{ $data }
	or return;

    if ( $context->{data} ) {
	push @{ $context->{data} }, @{ $data };
    } else {