File Coverage

blib/lib/Protocol/HTTP2/Server.pm
Criterion Covered Total %
statement 87 129 67.4
branch 18 44 40.9
condition 1 3 33.3
subroutine 19 24 79.1
pod 7 7 100.0
total 132 207 63.7


line stmt bran cond sub pod time code
1             package Protocol::HTTP2::Server;
2 5     5   2335 use strict;
  5         10  
  5         160  
3 5     5   21 use warnings;
  5         8  
  5         118  
4 5     5   19 use Protocol::HTTP2::Connection;
  5         7  
  5         131  
5 5         1390 use Protocol::HTTP2::Constants qw(:frame_types :flags :states :endpoints
6 5     5   20 :settings :limits const_name);
  5         6  
7 5     5   26 use Protocol::HTTP2::Trace qw(tracer);
  5         9  
  5         186  
8 5     5   22 use Carp;
  5         5  
  5         209  
9 5     5   21 use Scalar::Util ();
  5         7  
  5         1870  
10              
11             =encoding utf-8
12              
13             =head1 NAME
14              
15             Protocol::HTTP2::Server - HTTP/2 server
16              
17             =head1 SYNOPSIS
18              
19             use Protocol::HTTP2::Server;
20              
21             # You must create tcp server yourself
22             use AnyEvent;
23             use AnyEvent::Socket;
24             use AnyEvent::Handle;
25              
26             my $w = AnyEvent->condvar;
27              
28             # Plain-text HTTP/2 connection
29             tcp_server 'localhost', 8000, sub {
30             my ( $fh, $peer_host, $peer_port ) = @_;
31             my $handle;
32             $handle = AnyEvent::Handle->new(
33             fh => $fh,
34             autocork => 1,
35             on_error => sub {
36             $_[0]->destroy;
37             print "connection error\n";
38             },
39             on_eof => sub {
40             $handle->destroy;
41             }
42             );
43              
44             # Create Protocol::HTTP2::Server object
45             my $server;
46             $server = Protocol::HTTP2::Server->new(
47             on_request => sub {
48             my ( $stream_id, $headers, $data ) = @_;
49             my $message = "hello, world!";
50              
51             # Response to client
52             $server->response(
53             ':status' => 200,
54             stream_id => $stream_id,
55              
56             # HTTP/1.1 Headers
57             headers => [
58             'server' => 'perl-Protocol-HTTP2/0.13',
59             'content-length' => length($message),
60             'cache-control' => 'max-age=3600',
61             'date' => 'Fri, 18 Apr 2014 07:27:11 GMT',
62             'last-modified' => 'Thu, 27 Feb 2014 10:30:37 GMT',
63             ],
64              
65             # Content
66             data => $message,
67             );
68             },
69             );
70              
71             # First send settings to peer
72             while ( my $frame = $server->next_frame ) {
73             $handle->push_write($frame);
74             }
75              
76             # Receive clients frames
77             # Reply to client
78             $handle->on_read(
79             sub {
80             my $handle = shift;
81              
82             $server->feed( $handle->{rbuf} );
83              
84             $handle->{rbuf} = undef;
85             while ( my $frame = $server->next_frame ) {
86             $handle->push_write($frame);
87             }
88             $handle->push_shutdown if $server->shutdown;
89             }
90             );
91             };
92              
93             $w->recv;
94              
95              
96              
97             =head1 DESCRIPTION
98              
99             Protocol::HTTP2::Server is HTTP/2 server library. It's intended to make
100             http2-server implementations on top of your favorite event loop.
101              
102             See also L - AnyEvent HTTP/2 Server
103             for PSGI based on L.
104              
105             =head2 METHODS
106              
107             =head3 new
108              
109             Initialize new server object
110              
111             my $server = Procotol::HTTP2::Client->new( %options );
112              
113             Availiable options:
114              
115             =over
116              
117             =item on_request => sub {...}
118              
119             Callback invoked when receiving client's requests
120              
121             on_request => sub {
122             # Stream ID, headers array reference and body of request
123             my ( $stream_id, $headers, $data ) = @_;
124              
125             my $message = "hello, world!";
126             $server->response(
127             ':status' => 200,
128             stream_id => $stream_id,
129             headers => [
130             'server' => 'perl-Protocol-HTTP2/0.13',
131             'content-length' => length($message),
132             ],
133             data => $message,
134             );
135             ...
136             },
137              
138              
139             =item upgrade => 0|1
140              
141             Use HTTP/1.1 Upgrade to upgrade protocol from HTTP/1.1 to HTTP/2. Upgrade
142             possible only on plain (non-tls) connection.
143              
144             See
145             L
146              
147             =item on_error => sub {...}
148              
149             Callback invoked on protocol errors
150              
151             on_error => sub {
152             my $error = shift;
153             ...
154             },
155              
156             =item on_change_state => sub {...}
157              
158             Callback invoked every time when http/2 streams change their state.
159             See
160             L
161              
162             on_change_state => sub {
163             my ( $stream_id, $previous_state, $current_state ) = @_;
164             ...
165             },
166              
167             =back
168              
169             =cut
170              
171             sub new {
172 14     14 1 50765 my ( $class, %opts ) = @_;
173 0         0 my $self = {
174             con => undef,
175             input => '',
176             settings => {
177             &SETTINGS_MAX_CONCURRENT_STREAMS => DEFAULT_MAX_CONCURRENT_STREAMS,
178 14 50       2105 exists $opts{settings} ? %{ delete $opts{settings} } : ()
179             },
180             };
181 14 100       1962 if ( exists $opts{on_request} ) {
182 12         1989 Scalar::Util::weaken( my $self = $self );
183              
184 12         1968 $self->{cb} = delete $opts{on_request};
185             $opts{on_new_peer_stream} = sub {
186 10     10   2115 my $stream_id = shift;
187             $self->{con}->stream_cb(
188             $stream_id,
189             HALF_CLOSED,
190             sub {
191 10         2074 $self->{cb}->(
192             $stream_id,
193             $self->{con}->stream_headers($stream_id),
194             $self->{con}->stream_data($stream_id),
195             );
196             }
197 10         2150 );
198             }
199 12         3882 }
200              
201 14         2026 $self->{con} =
202             Protocol::HTTP2::Connection->new( SERVER, %opts,
203             settings => $self->{settings} );
204 14 50       2011 $self->{con}->enqueue( SETTINGS, 0, 0, $self->{settings} )
205             unless $self->{con}->upgrade;
206              
207 14         3942 bless $self, $class;
208             }
209              
210             =head3 response
211              
212             Prepare response
213              
214             my $message = "hello, world!";
215             $server->response(
216              
217             # HTTP/2 status
218             ':status' => 200,
219              
220             # Stream ID
221             stream_id => $stream_id,
222              
223             # HTTP/1.1 headers
224             headers => [
225             'server' => 'perl-Protocol-HTTP2/0.01',
226             'content-length' => length($message),
227             ],
228              
229             # Body of response
230             data => $message,
231             );
232              
233             =cut
234              
235             my @must = (qw(:status));
236              
237             sub response {
238 0     0 1 0 my ( $self, %h ) = @_;
239 0         0 my @miss = grep { !exists $h{$_} } @must;
  0         0  
240 0 0       0 croak "Missing headers in response: @miss" if @miss;
241              
242 0         0 my $con = $self->{con};
243              
244 0         0 $con->send_headers(
245             $h{stream_id},
246             [
247 0         0 ( map { $_ => $h{$_} } @must ),
248 0 0       0 exists $h{headers} ? @{ $h{headers} } : ()
    0          
249             ],
250             exists $h{data} ? 0 : 1
251             );
252 0 0       0 $con->send_data( $h{stream_id}, $h{data}, 1 ) if exists $h{data};
253 0         0 return $self;
254             }
255              
256             =head3 response_stream
257              
258             If body of response is not yet ready or server will stream data
259              
260             # P::H::Server::Stream object
261             my $server_stream;
262             $server_stream = $server->response_stream(
263              
264             # HTTP/2 status
265             ':status' => 200,
266              
267             # Stream ID
268             stream_id => $stream_id,
269              
270             # HTTP/1.1 headers
271             headers => [
272             'server' => 'perl-Protocol-HTTP2/0.01',
273             ],
274              
275             # Callback if client abort this stream
276             on_cancel => sub {
277             ...
278             }
279             );
280              
281             # Send partial data
282             $server_stream->send($chunk_of_data);
283             $server_stream->send($chunk_of_data);
284              
285             ## 3 ways to finish stream:
286             #
287             # The best: send last chunk and close stream in one action
288             $server_stream->last($chunk_of_data);
289              
290             # Close the stream (will send empty frame)
291             $server_stream->close();
292              
293             # Destroy object (will send empty frame)
294             undef $server_stream
295              
296             =cut
297              
298             {
299              
300             package Protocol::HTTP2::Server::Stream;
301 5     5   24 use Protocol::HTTP2::Constants qw(:states);
  5         9  
  5         550  
302 5     5   46 use Scalar::Util ();
  5         8  
  5         4319  
303              
304             sub new {
305 10     10   2098 my ( $class, %opts ) = @_;
306 10         2376 my $self = bless {%opts}, $class;
307              
308 10 100       2132 if ( $self->{on_cancel} ) {
309 5         1160 Scalar::Util::weaken( my $self = $self );
310             $self->{con}->stream_cb(
311             $self->{stream_id},
312             CLOSED,
313             sub {
314 5 50   5   1031 return if $self->{done};
315 5         1025 $self->{done} = 1;
316 5         993 $self->{on_cancel}->();
317             }
318 5         1199 );
319             }
320              
321 10         6001 $self;
322             }
323              
324             sub send {
325 15     15   6885 my $self = shift;
326 15         2933 $self->{con}->send_data( $self->{stream_id}, shift );
327             }
328              
329             sub last {
330 0     0   0 my $self = shift;
331 0         0 $self->{done} = 1;
332 0         0 $self->{con}->send_data( $self->{stream_id}, shift, 1 );
333             }
334              
335             sub close {
336 5     5   2030 my $self = shift;
337 5         1032 $self->{done} = 1;
338 5         1162 $self->{con}->send_data( $self->{stream_id}, undef, 1 );
339             }
340              
341             sub DESTROY {
342 9     9   11348 my $self = shift;
343 9 50 33     9352 $self->{con}->send_data( $self->{stream_id}, undef, 1 )
344             unless $self->{done} || !$self->{con};
345             }
346             }
347              
348             sub response_stream {
349 10     10 1 6299 my ( $self, %h ) = @_;
350 10         2053 my @miss = grep { !exists $h{$_} } @must;
  10         4342  
351 10 50       2104 croak "Missing headers in response_stream: @miss" if @miss;
352              
353 10         2034 my $con = $self->{con};
354              
355 10         4032 $con->send_headers(
356             $h{stream_id},
357             [
358 10         4173 ( map { $_ => $h{$_} } @must ),
359 10 50       2170 exists $h{headers} ? @{ $h{headers} } : ()
360             ],
361             0
362             );
363              
364 10         2162 return Protocol::HTTP2::Server::Stream->new(
365             con => $con,
366             stream_id => $h{stream_id},
367             on_cancel => $h{on_cancel},
368             );
369             }
370              
371             =head3 push
372              
373             Prepare Push Promise. See
374             L
375              
376             # Example of push inside of on_request callback
377             on_request => sub {
378             my ( $stream_id, $headers, $data ) = @_;
379             my %h = (@$headers);
380              
381             # Push promise (must be before response)
382             if ( $h{':path'} eq '/index.html' ) {
383              
384             # index.html contain styles.css resource, so server can push
385             # "/style.css" to client before it request it to increase speed
386             # of loading of whole page
387             $server->push(
388             ':authority' => 'locahost:8000',
389             ':method' => 'GET',
390             ':path' => '/style.css',
391             ':scheme' => 'http',
392             stream_id => $stream_id,
393             );
394             }
395              
396             $server->response(...);
397             ...
398             }
399              
400             =cut
401              
402             my @must_pp = (qw(:authority :method :path :scheme));
403              
404             sub push {
405 0     0 1 0 my ( $self, %h ) = @_;
406 0         0 my $con = $self->{con};
407 0         0 my @miss = grep { !exists $h{$_} } @must_pp;
  0         0  
408 0 0       0 croak "Missing headers in push promise: @miss" if @miss;
409 0 0       0 croak "Can't push on my own stream. "
410             . "Seems like a recursion in request callback."
411             if $h{stream_id} % 2 == 0;
412              
413 0         0 my $promised_sid = $con->new_stream;
414 0         0 $con->stream_promised_sid( $h{stream_id}, $promised_sid );
415              
416 0         0 my @headers = map { $_ => $h{$_} } @must_pp;
  0         0  
417              
418 0         0 $con->send_pp_headers( $h{stream_id}, $promised_sid, \@headers, );
419              
420             # send promised response after current stream is closed
421             $con->stream_cb(
422             $h{stream_id},
423             CLOSED,
424             sub {
425 0     0   0 $self->{cb}->( $promised_sid, \@headers );
426             }
427 0         0 );
428              
429 0         0 return $self;
430             }
431              
432             =head3 shutdown
433              
434             Get connection status:
435              
436             =over
437              
438             =item 0 - active
439              
440             =item 1 - closed (you can terminate connection)
441              
442             =back
443              
444             =cut
445              
446             sub shutdown {
447 0     0 1 0 shift->{con}->shutdown;
448             }
449              
450             =head3 next_frame
451              
452             get next frame to send over connection to client.
453             Returns:
454              
455             =over
456              
457             =item undef - on error
458              
459             =item 0 - nothing to send
460              
461             =item binary string - encoded frame
462              
463             =back
464              
465             # Example
466             while ( my $frame = $server->next_frame ) {
467             syswrite $fh, $frame;
468             }
469              
470             =cut
471              
472             sub next_frame {
473 89     89 1 31998 my $self = shift;
474 89         16191 my $frame = $self->{con}->dequeue;
475 89 100       16323 if ($frame) {
476 54         10406 my ( $length, $type, $flags, $stream_id ) =
477             $self->{con}->frame_header_decode( \$frame, 0 );
478 54         10111 tracer->debug(
479             sprintf "Send one frame to a wire:"
480             . " type(%s), length(%i), flags(%08b), sid(%i)\n",
481             const_name( 'frame_types', $type ), $length, $flags, $stream_id
482             );
483             }
484 89         31674 return $frame;
485             }
486              
487             =head3 feed
488              
489             Feed decoder with chunks of client's request
490              
491             sysread $fh, $binary_data, 4096;
492             $server->feed($binary_data);
493              
494             =cut
495              
496             sub feed {
497 55     55 1 20369 my ( $self, $chunk ) = @_;
498 55         10131 $self->{input} .= $chunk;
499 55         10002 my $offset = 0;
500 55         10024 my $con = $self->{con};
501 55         10002 tracer->debug( "got " . length($chunk) . " bytes on a wire\n" );
502              
503 55 50       9858 if ( $con->upgrade ) {
504 0         0 my @headers;
505 0         0 my $len =
506             $con->decode_upgrade_request( \$self->{input}, $offset, \@headers );
507 0 0       0 $con->shutdown(1) unless defined $len;
508 0 0       0 return unless $len;
509              
510 0         0 substr( $self->{input}, $offset, $len ) = '';
511              
512 0         0 $con->enqueue_raw( $con->upgrade_response );
513 0         0 $con->enqueue( SETTINGS, 0, 0,
514             {
515             &SETTINGS_MAX_CONCURRENT_STREAMS =>
516             DEFAULT_MAX_CONCURRENT_STREAMS
517             }
518             );
519 0         0 $con->upgrade(0);
520              
521             # The HTTP/1.1 request that is sent prior to upgrade is assigned stream
522             # identifier 1 and is assigned default priority values (Section 5.3.5).
523             # Stream 1 is implicitly half closed from the client toward the server,
524             # since the request is completed as an HTTP/1.1 request. After
525             # commencing the HTTP/2 connection, stream 1 is used for the response.
526              
527 0         0 $con->new_peer_stream(1);
528 0         0 $con->stream_headers( 1, \@headers );
529 0         0 $con->stream_state( 1, HALF_CLOSED );
530             }
531              
532 55 100       9967 if ( !$con->preface ) {
533 11         2329 my $len = $con->preface_decode( \$self->{input}, $offset );
534 11 50       2399 unless ( defined $len ) {
535 0         0 tracer->error("invalid preface. shutdown connection\n");
536 0         0 $con->shutdown(1);
537             }
538 11 50       2400 return unless $len;
539 11         2298 tracer->debug("got preface\n");
540 11         2520 $offset += $len;
541 11         2431 $con->preface(1);
542             }
543              
544 55         10671 while ( my $len = $con->frame_decode( \$self->{input}, $offset ) ) {
545 44         8264 tracer->debug("decoded frame at $offset, length $len\n");
546 44         17245 $offset += $len;
547             }
548 55 50       21039 substr( $self->{input}, 0, $offset ) = '' if $offset;
549             }
550              
551             1;