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


line stmt bran cond sub pod time code
1             ##----------------------------------------------------------------------------
2             ## Asynchronous HTTP Request and Promise - ~/lib/HTTP/Promise/Headers/AltSvc.pm
3             ## Version v0.1.0
4             ## Copyright(c) 2022 DEGUEST Pte. Ltd.
5             ## Author: Jacques Deguest <jack@deguest.jp>
6             ## Created 2022/05/06
7             ## Modified 2022/05/06
8             ## All rights reserved.
9             ##
10             ##
11             ## This program is free software; you can redistribute it and/or modify it
12             ## under the same terms as Perl itself.
13             ##----------------------------------------------------------------------------
14             package HTTP::Promise::Headers::AltSvc;
15             BEGIN
16             {
17 3     3   3363 use strict;
  3         7  
  3         94  
18 3     3   16 use warnings;
  3         8  
  3         78  
19 3     3   15 use warnings::register;
  3         8  
  3         355  
20 3     3   51 use parent qw( HTTP::Promise::Headers::Generic );
  3         27  
  3         17  
21 3     3   189 use URI::Escape::XS ();
  3         6  
  3         74  
22 3     3   60 our $VERSION = 'v0.1.0';
23             };
24              
25 3     3   16 use strict;
  3         6  
  3         54  
26 3     3   14 use warnings;
  3         6  
  3         2812  
27              
28             sub init
29             {
30 4     4 1 309861 my $self = shift( @_ );
31 4 50 66     58 @_ = () if( @_ == 1 && $self->_is_a( $_[0] => 'Module::Generic::Null' ) );
32 4 100       82 if( @_ )
33             {
34 3         16 my $this = shift( @_ );
35 3         25 my $params = $self->_get_args_as_hash( @_ );
36 3 50 66     38 unless( ( $self->_is_array( $this ) && scalar( @$this ) == 2 ) ||
      66        
      33        
37             !ref( $this ) ||
38             overload::Method( $this, "''" ) )
39             {
40 0         0 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." ) );
41             }
42 3 100       111 my $hv = $self->_is_array( $this ) ? $self->_new_hv( $this ) : $self->_parse_header_value( $this );
43 3 50       968 return( $self->pass_error ) if( !defined( $hv ) );
44 3 50       15 $hv->_set_get_params( $params ) if( scalar( keys( %$params ) ) );
45 3         12 $hv->encode(1);
46 3         2571 $self->_hv( $hv );
47             }
48 4         319 $self->{_init_strict_use_sub} = 1;
49 4 50       24 $self->SUPER::init( @_ ) || return( $self->pass_error );
50 4         30 $self->_field_name( 'Alt-Svc' );
51 4         3237 return( $self );
52             }
53              
54 4     4 1 265295 sub as_string { return( shift->_hv_as_string( @_ ) ); }
55              
56             sub alternative
57             {
58 0     0 1 0 my $self = shift( @_ );
59 0 0       0 if( @_ )
60             {
61 0 0       0 return( $self->error( "Bad arguments provided. Usage: \$h->alternative( \$proto, \$auth )" ) ) if( @_ > 2 );
62 0 0       0 my( $proto, $auth ) = @_ > 1 ? @_[0,1] : $_[0];
63             # need escaping?
64 0 0       0 if( @_ == 1 )
65             {
66 0 0       0 return( $self->error( "Bad argument provided. You need to provide a protocol=authority." ) ) if( index( $proto, '=' ) == -1 );
67 0         0 ( $proto, $auth ) = split( /=/, $proto, 2 );
68 0 0       0 $proto = $self->_unescape( $proto ) if( $proto =~ /\%(?=\d{2})/ );
69             }
70 0         0 my $hv;
71 0 0       0 if( $hv = $self->_hv )
72             {
73 0         0 $hv->value( [ $proto, $auth ] );
74             }
75             else
76             {
77 0         0 $hv = $self->_new_hv( [ $proto, $auth ] );
78 0         0 $hv->encode(1);
79 0         0 $self->_hv( $hv );
80             }
81             }
82             else
83             {
84 0   0     0 my $hv = $self->_hv || return( '' );
85 0         0 my $ref = $hv->value;
86 0 0       0 return( wantarray() ? () : '' ) if( $ref->is_empty );
    0          
87 0 0       0 return( $ref->list ) if( wantarray() );
88 0         0 my( $proto, $auth ) = $ref->list;
89             # $proto = $self->_escape( $proto );
90 0         0 $proto = $hv->token_escape( $proto );
91 0         0 return( join( '=', $proto, $auth ) );
92             }
93             }
94              
95             # This needs a protocol to be set first
96 2     2 1 76559 sub authority { return( shift->_hv->value_data( @_ ) ); }
97              
98 0     0 1 0 sub ma { return( shift->_set_get_param( ma => @_ ) ); }
99              
100 0     0 1 0 sub param { return( shift->_set_get_param( @_ ) ); }
101              
102 0     0 1 0 sub params { return( shift->_set_get_params( @_ ) ); }
103              
104 0     0 1 0 sub persist { return( shift->_set_get_param( persist => @_ ) ); }
105              
106             sub protocol
107             {
108 2     2 1 22 my $self = shift( @_ );
109 2 50       7 if( @_ )
110             {
111 0         0 my $proto = shift( @_ );
112 0 0 0     0 return( $self->error( "Value provided for protocol is empty." ) ) if( !defined( $proto ) || !length( "$proto" ) );
113 0         0 my $hv = $self->_hv;
114 0 0       0 if( $hv )
115             {
116 0         0 $hv->value_name( $proto );
117             }
118             else
119             {
120 0         0 $hv = $self->_new_hv( $proto );
121 0         0 $self->_hv( $hv );
122             }
123             }
124             else
125             {
126 2   50     8 my $hv = $self->_hv || return( '' );
127 2         78 return( $hv->value_name );
128             }
129             }
130              
131             # As per rfc7838, section 3: <https://tools.ietf.org/html/rfc7838#section-3>
132             # sub _escape
133             # {
134             # my $self = shift( @_ );
135             # my $v = shift( @_ );
136             # $v =~ s/([=:%]+)/sprintf("%%%02X", ord($1))/ge;
137             # return( $v );
138             # }
139 0     0     sub _escape { return( URI::Escape::XS::uri_escape( $_[1] ) ); }
140              
141             # sub _unescape
142             # {
143             # my $self = shift( @_ );
144             # my $v = shift( @_ );
145             # $v =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
146             # return( $v );
147             # }
148 0     0     sub _unescape { return( URI::Escape::XS::uri_unescape( $_[1] ) ); }
149              
150             1;
151             # NOTE: POD
152             __END__
153              
154             =encoding utf-8
155              
156             =head1 NAME
157              
158             HTTP::Promise::Headers::AltSvc - AltSvc Header Field
159              
160             =head1 SYNOPSIS
161              
162             use HTTP::Promise::Headers::AltSvc;
163             my $alt = HTTP::Promise::Headers::AltSvc->new ||
164             die( HTTP::Promise::Headers::AltSvc->error, "\n" );
165             $alt->alternative( q{h2="new.example.org:80"} );
166             $alt->alternative( 'h2', 'new.example.org:80' );
167             my $def = $alt->alternative; # h2="new.example.org:80"
168             $alt->ma(2592000);
169             $alt->persist(1);
170             $alt->authority( 'new.example.org:443' );
171             $alt->protocol( 'h2' );
172             say "$alt"; # stringifies
173             say $alt->as_string; # same
174              
175             =head1 VERSION
176              
177             v0.1.0
178              
179             =head1 DESCRIPTION
180              
181             The following description is taken from Mozilla documentation.
182              
183             Alt-Svc: clear
184             Alt-Svc: <protocol-id>=<alt-authority>
185              
186             The special value clear indicates that the origin requests all alternative services for that origin to be invalidated.
187              
188             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.
189              
190             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.
191              
192             Alt-Svc: h2=":443"; ma=2592000;
193             Alt-Svc: h2=":443"; ma=2592000; persist=1
194             Alt-Svc: h2="alt.example.com:443", h2=":443"
195             Alt-Svc: h3-25=":443"; ma=3600, h2=":443"; ma=3600
196              
197             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.
198              
199             You can achieve this the following way:
200              
201             my $alt1 = HTTP::Promise::Headers::AltSvc->new( q{h2="alt.example.com:443"} );
202             $alt1->ma(3600);
203             $alt1->persist(1);
204             my $alt2 = HTTP::Promise::Headers::AltSvc->new( q{h2=":443"} );
205             $alt2->ma(3600);
206             my $headers = HTTP::Promise::Headers->new;
207             $headers->push_header( alt_svc => "$alt1", alt_svc => "$alt2" );
208              
209             =head1 CONSTRUCTOR
210              
211             =head2 new
212              
213             You can create a new instance of this class without passing any parameter, and set them afterward.
214              
215             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.
216              
217             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:
218              
219             my $alt = HTTP::Promise::Headers::AltSvc->new( 'w=x:y#z' );
220              
221             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:
222              
223             my $alt = HTTP::Promise::Headers::AltSvc->new( ['w=x:y#z', 'new.example.org:443'] );
224              
225             =head1 METHODS
226              
227             =head2 alternative
228              
229             Sets or gets the alternative protocol and authority.
230              
231             For example:
232              
233             $h->alternative( $proto, $auth );
234             my $alt = $h->alternative; # h2="alt.example.com:443"
235              
236             =head2 authority
237              
238             Sets or gets the authority, which is the value in the equal assignment, such as:
239              
240             h2="alt.example.com:443"
241              
242             Here the authority would be C<alt.example.com:443>
243              
244             my $u = URI->new( 'https://alt.example.com' );
245             $h->authority( $u->host_port );
246              
247             =head2 ma
248              
249             This is optional and takes a number.
250              
251             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.
252              
253             =head2 param
254              
255             Set or get an arbitrary name-value pair attribute.
256              
257             =head2 params
258              
259             Set or get multiple name-value parameters.
260              
261             Calling this without any parameters, retrieves the associated L<hash object|Module::Generic::Hash>
262              
263             =head2 persist
264              
265             This is optional and takes a number.
266              
267             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.
268              
269             =head2 protocol
270              
271             Sets or gets the protocol. For example:
272              
273             $alt->protocol( 'h2' );
274              
275             Here, C<h2> is the protocol and means HTTP/2. C<h3-25> would be for draft 25 of the HTTP/3 protocol.
276              
277             You can even pass unsafe characters. They will be encoded upon stringification:
278              
279             $alt->protocol( 'w=x:y#z' ); # example from rfc7838
280              
281             =head1 AUTHOR
282              
283             Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>
284              
285             =head1 SEE ALSO
286              
287             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>
288              
289             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>
290              
291             =head1 COPYRIGHT & LICENSE
292              
293             Copyright(c) 2022 DEGUEST Pte. Ltd.
294              
295             All rights reserved.
296              
297             This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
298              
299             =cut