File Coverage

lib/HTTP/Promise/Headers/AltSvc.pm

Criterion	Covered	Total	%
statement	43	78	55.1
branch	10	40	25.0
condition	8	19	42.1
subroutine	12	19	63.1
pod	9	9	100.0
total	82	165	49.7

##----------------------------------------------------------------------------
## Asynchronous HTTP Request and Promise - ~/lib/HTTP/Promise/Headers/AltSvc.pm
## Version v0.1.0
## Copyright(c) 2022 DEGUEST Pte. Ltd.
## Author: Jacques Deguest <[e-mail]>
## Created 2022/05/06
## Modified 2022/05/06
## All rights reserved.
##
##
## This program is free software; you can redistribute  it  and/or  modify  it
## under the same terms as Perl itself.
##----------------------------------------------------------------------------
package HTTP::Promise::Headers::AltSvc;
BEGIN
{
    use strict;
    use warnings;
    use warnings::register;
    use parent qw( HTTP::Promise::Headers::Generic );
    use URI::Escape::XS ();
    our $VERSION = 'v0.1.0';
};

use strict;
use warnings;

sub init
{
    my $self = shift( @_ );
    @_ = () if( @_ == 1 && $self->_is_a( $_[0] => 'Module::Generic::Null' ) );
    if( @_ )
    {
        my $this = shift( @_ );
        my $params = $self->_get_args_as_hash( @_ );
        unless( ( $self->_is_array( $this ) && scalar( @$this ) == 2 ) ||
                !ref( $this ) ||
                overload::Method( $this, "''" ) )
        {
            return( $self->error( "Wrong alternate server name-value provided '$this'. I was expecting either a name=value string or an array reference with 2 elements." ) );
        }
        my $hv = $self->_is_array( $this ) ? $self->_new_hv( $this ) : $self->_parse_header_value( $this );
        return( $self->pass_error ) if( !defined( $hv ) );
        $hv->_set_get_params( $params ) if( scalar( keys( %$params ) ) );
        $hv->encode(1);
        $self->_hv( $hv );
    }
    $self->{_init_strict_use_sub} = 1;
    $self->SUPER::init( @_ ) || return( $self->pass_error );
    $self->_field_name( 'Alt-Svc' );
    return( $self );
}

sub as_string { return( shift->_hv_as_string( @_ ) ); }

sub alternative
{
    my $self = shift( @_ );
    if( @_ )
    {
        return( $self->error( "Bad arguments provided. Usage: \$h->alternative( \$proto, \$auth )" ) ) if( @_ > 2 );
        my( $proto, $auth ) = @_ > 1 ? @_[0,1] : $_[0];
        # need escaping?
        if( @_ == 1 )
        {
            return( $self->error( "Bad argument provided. You need to provide a protocol=authority." ) ) if( index( $proto, '=' ) == -1 );
            ( $proto, $auth ) = split( /=/, $proto, 2 );
            $proto = $self->_unescape( $proto ) if( $proto =~ /\%(?=\d{2})/ );
        }
        my $hv;
        if( $hv = $self->_hv )
        {
            $hv->value( [ $proto, $auth ] );
        }
        else
        {
            $hv = $self->_new_hv( [ $proto, $auth ] );
            $hv->encode(1);
            $self->_hv( $hv );
        }
    }
    else
    {
        my $hv = $self->_hv || return( '' );
        my $ref = $hv->value;
        return( wantarray() ? () : '' ) if( $ref->is_empty );
        return( $ref->list ) if( wantarray() );
        my( $proto, $auth ) = $ref->list;
        # $proto = $self->_escape( $proto );
        $proto = $hv->token_escape( $proto );
        return( join( '=', $proto, $auth ) );
    }
}

# This needs a protocol to be set first
sub authority { return( shift->_hv->value_data( @_ ) ); }

sub ma { return( shift->_set_get_param( ma => @_ ) ); }

sub param { return( shift->_set_get_param( @_ ) ); }

sub params { return( shift->_set_get_params( @_ ) ); }

sub persist { return( shift->_set_get_param( persist => @_ ) ); }

sub protocol
{
    my $self = shift( @_ );
    if( @_ )
    {
        my $proto = shift( @_ );
        return( $self->error( "Value provided for protocol is empty." ) ) if( !defined( $proto ) || !length( "$proto" ) );
        my $hv = $self->_hv;
        if( $hv )
        {
            $hv->value_name( $proto );
        }
        else
        {
            $hv = $self->_new_hv( $proto );
            $self->_hv( $hv );
        }
    }
    else
    {
        my $hv = $self->_hv || return( '' );
        return( $hv->value_name );
    }
}

# As per rfc7838, section 3: <https://tools.ietf.org/html/rfc7838#section-3>
# sub _escape
# {
#     my $self = shift( @_ );
#     my $v = shift( @_ );
#     $v =~ s/([=:%]+)/sprintf("%%%02X", ord($1))/ge;
#     return( $v );
# }
sub _escape { return( URI::Escape::XS::uri_escape( $_[1] ) ); }

# sub _unescape
# {
#     my $self = shift( @_ );
#     my $v = shift( @_ );
#     $v =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
#     return( $v );
# }
sub _unescape { return( URI::Escape::XS::uri_unescape( $_[1] ) ); }

1;
# NOTE: POD
__END__

=encoding utf-8

=head1 NAME

HTTP::Promise::Headers::AltSvc - AltSvc Header Field

=head1 SYNOPSIS

    use HTTP::Promise::Headers::AltSvc;
    my $alt = HTTP::Promise::Headers::AltSvc->new ||
        die( HTTP::Promise::Headers::AltSvc->error, "\n" );
    $alt->alternative( q{h2="new.example.org:80"} );
    $alt->alternative( 'h2', 'new.example.org:80' );
    my $def = $alt->alternative; # h2="new.example.org:80"
    $alt->ma(2592000);
    $alt->persist(1);
    $alt->authority( 'new.example.org:443' );
    $alt->protocol( 'h2' );
    say "$alt"; # stringifies
    say $alt->as_string; # same

=head1 VERSION

    v0.1.0

=head1 DESCRIPTION

The following description is taken from Mozilla documentation.

    Alt-Svc: clear
    Alt-Svc: <protocol-id>=<alt-authority>

The special value clear indicates that the origin requests all alternative services for that origin to be invalidated.

C<protocol-id> is the C<ALPN> protocol identifier. Examples include h2 for HTTP/2 and h3-25 for draft 25 of the HTTP/3 protocol.

C<alt-authority> is the quoted string specifying the alternative authority which consists of an optional host override, a colon, and a mandatory port number.

    Alt-Svc: h2=":443"; ma=2592000;
    Alt-Svc: h2=":443"; ma=2592000; persist=1
    Alt-Svc: h2="alt.example.com:443", h2=":443"
    Alt-Svc: h3-25=":443"; ma=3600, h2=":443"; ma=3600

Multiple entries can be specified in a single C<Alt-Svc> header using comma as separator. In that case, early entries are considered more preferable.

You can achieve this the following way:

    my $alt1 = HTTP::Promise::Headers::AltSvc->new( q{h2="alt.example.com:443"} );
    $alt1->ma(3600);
    $alt1->persist(1);
    my $alt2 = HTTP::Promise::Headers::AltSvc->new( q{h2=":443"} );
    $alt2->ma(3600);
    my $headers = HTTP::Promise::Headers->new;
    $headers->push_header( alt_svc => "$alt1", alt_svc => "$alt2" );

=head1 CONSTRUCTOR

=head2 new

You can create a new instance of this class without passing any parameter, and set them afterward.

If you want to set parameters upon object instantiation, this takes either an array reference with 2 values (C<protocol> and C<authority>), or a string (or something that stringifies, and an optional hash or hash reference of parameters and it returns a new object.

If you provide a string, it will be parsed, so be careful what you provide, and make sure that non-ascii characters are escaped first. For example:

    my $alt = HTTP::Promise::Headers::AltSvc->new( 'w=x:y#z' );

It will be interpreted, wrongly, as C<w> being the protocol and C<x:y#z>, so instead you would need to either escape it before (with L<URI::Escape::XS> for example), or provide it as an array of 2 elements (protocol and authority), such as:

    my $alt = HTTP::Promise::Headers::AltSvc->new( ['w=x:y#z', 'new.example.org:443'] );

=head1 METHODS

=head2 alternative

Sets or gets the alternative protocol and authority.

For example:

    $h->alternative( $proto, $auth );
    my $alt = $h->alternative; # h2="alt.example.com:443"

=head2 authority

Sets or gets the authority, which is the value in the equal assignment, such as:

    h2="alt.example.com:443"

Here the authority would be C<alt.example.com:443>

    my $u = URI->new( 'https://alt.example.com' );
    $h->authority( $u->host_port );

=head2 ma

This is optional and takes a number.

The number of seconds for which the alternative service is considered fresh. If omitted, it defaults to 24 hours. Alternative service entries can be cached for up to <max-age> seconds, minus the age of the response (from the Age header). Once the cached entry expires, the client can no longer use this alternative service for new connections.

=head2 param

Set or get an arbitrary name-value pair attribute.

=head2 params

Set or get multiple name-value parameters.

Calling this without any parameters, retrieves the associated L<hash object|Module::Generic::Hash>

=head2 persist

This is optional and takes a number.

Usually cached alternative service entries are cleared on network configuration changes. Use of the persist=1 parameter requests that the entry not be deleted by such changes.

=head2 protocol

Sets or gets the protocol. For example:

    $alt->protocol( 'h2' );

Here, C<h2> is the protocol and means HTTP/2. C<h3-25> would be for draft 25 of the HTTP/3 protocol.

You can even pass unsafe characters. They will be encoded upon stringification:

    $alt->protocol( 'w=x:y#z' ); # example from rfc7838

=head1 AUTHOR

Jacques Deguest E<lt>F<[e-mail]>E<gt>

=head1 SEE ALSO

L<Mozilla documentation|https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Alt-Svc>, L<rfc7838, section 3|https://tools.ietf.org/html/rfc7838#section-3>

L<HTTP::Promise>, L<HTTP::Promise::Request>, L<HTTP::Promise::Response>, L<HTTP::Promise::Message>, L<HTTP::Promise::Entity>, L<HTTP::Promise::Headers>, L<HTTP::Promise::Body>, L<HTTP::Promise::Body::Form>, L<HTTP::Promise::Body::Form::Data>, L<HTTP::Promise::Body::Form::Field>, L<HTTP::Promise::Status>, L<HTTP::Promise::MIME>, L<HTTP::Promise::Parser>, L<HTTP::Promise::IO>, L<HTTP::Promise::Stream>, L<HTTP::Promise::Exception>

=head1 COPYRIGHT & LICENSE

Copyright(c) 2022 DEGUEST Pte. Ltd.

All rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut