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 |