1package Protocol::HTTP2::Server; 2use strict; 3use warnings; 4use Protocol::HTTP2::Connection; 5use Protocol::HTTP2::Constants qw(:frame_types :flags :states :endpoints 6 :settings :limits const_name); 7use Protocol::HTTP2::Trace qw(tracer); 8use Carp; 9use Scalar::Util (); 10 11=encoding utf-8 12 13=head1 NAME 14 15Protocol::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 99Protocol::HTTP2::Server is HTTP/2 server library. It's intended to make 100http2-server implementations on top of your favorite event loop. 101 102See also L<Shuvgey|https://github.com/vlet/Shuvgey> - AnyEvent HTTP/2 Server 103for PSGI based on L<Protocol::HTTP2::Server>. 104 105=head2 METHODS 106 107=head3 new 108 109Initialize new server object 110 111 my $server = Procotol::HTTP2::Client->new( %options ); 112 113Available options: 114 115=over 116 117=item on_request => sub {...} 118 119Callback 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 141Use HTTP/1.1 Upgrade to upgrade protocol from HTTP/1.1 to HTTP/2. Upgrade 142possible only on plain (non-tls) connection. 143 144See 145L<Starting HTTP/2 for "http" URIs|https://tools.ietf.org/html/rfc7540#section-3.2> 146 147=item on_error => sub {...} 148 149Callback invoked on protocol errors 150 151 on_error => sub { 152 my $error = shift; 153 ... 154 }, 155 156=item on_change_state => sub {...} 157 158Callback invoked every time when http/2 streams change their state. 159See 160L<Stream States|https://tools.ietf.org/html/rfc7540#section-5.1> 161 162 on_change_state => sub { 163 my ( $stream_id, $previous_state, $current_state ) = @_; 164 ... 165 }, 166 167=back 168 169=cut 170 171sub new { 172 my ( $class, %opts ) = @_; 173 my $self = { 174 con => undef, 175 input => '', 176 settings => { 177 &SETTINGS_MAX_CONCURRENT_STREAMS => DEFAULT_MAX_CONCURRENT_STREAMS, 178 exists $opts{settings} ? %{ delete $opts{settings} } : () 179 }, 180 }; 181 if ( exists $opts{on_request} ) { 182 Scalar::Util::weaken( my $self = $self ); 183 184 $self->{cb} = delete $opts{on_request}; 185 $opts{on_new_peer_stream} = sub { 186 my $stream_id = shift; 187 $self->{con}->stream_cb( 188 $stream_id, 189 HALF_CLOSED, 190 sub { 191 $self->{cb}->( 192 $stream_id, 193 $self->{con}->stream_headers($stream_id), 194 $self->{con}->stream_data($stream_id), 195 ); 196 } 197 ); 198 } 199 } 200 201 $self->{con} = 202 Protocol::HTTP2::Connection->new( SERVER, %opts, 203 settings => $self->{settings} ); 204 $self->{con}->enqueue( SETTINGS, 0, 0, $self->{settings} ) 205 unless $self->{con}->upgrade; 206 207 bless $self, $class; 208} 209 210=head3 response 211 212Prepare 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 235my @must = (qw(:status)); 236 237sub response { 238 my ( $self, %h ) = @_; 239 my @miss = grep { !exists $h{$_} } @must; 240 croak "Missing headers in response: @miss" if @miss; 241 242 my $con = $self->{con}; 243 244 $con->send_headers( 245 $h{stream_id}, 246 [ 247 ( map { $_ => $h{$_} } @must ), 248 exists $h{headers} ? @{ $h{headers} } : () 249 ], 250 exists $h{data} ? 0 : 1 251 ); 252 $con->send_data( $h{stream_id}, $h{data}, 1 ) if exists $h{data}; 253 return $self; 254} 255 256=head3 response_stream 257 258If 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 use Protocol::HTTP2::Constants qw(:states); 302 use Scalar::Util (); 303 304 sub new { 305 my ( $class, %opts ) = @_; 306 my $self = bless {%opts}, $class; 307 308 if ( my $on_cancel = $self->{on_cancel} ) { 309 Scalar::Util::weaken( my $self = $self ); 310 $self->{con}->stream_cb( 311 $self->{stream_id}, 312 CLOSED, 313 sub { 314 return if $self->{done}; 315 $self->{done} = 1; 316 $on_cancel->(); 317 } 318 ); 319 } 320 321 $self; 322 } 323 324 sub send { 325 my $self = shift; 326 $self->{con}->send_data( $self->{stream_id}, shift ); 327 } 328 329 sub last { 330 my $self = shift; 331 $self->{done} = 1; 332 $self->{con}->send_data( $self->{stream_id}, shift, 1 ); 333 } 334 335 sub close { 336 my $self = shift; 337 $self->{done} = 1; 338 $self->{con}->send_data( $self->{stream_id}, undef, 1 ); 339 } 340 341 sub DESTROY { 342 my $self = shift; 343 $self->{con}->send_data( $self->{stream_id}, undef, 1 ) 344 unless $self->{done} || !$self->{con}; 345 } 346} 347 348sub response_stream { 349 my ( $self, %h ) = @_; 350 my @miss = grep { !exists $h{$_} } @must; 351 croak "Missing headers in response_stream: @miss" if @miss; 352 353 my $con = $self->{con}; 354 355 $con->send_headers( 356 $h{stream_id}, 357 [ 358 ( map { $_ => $h{$_} } @must ), 359 exists $h{headers} ? @{ $h{headers} } : () 360 ], 361 0 362 ); 363 364 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 373Prepare Push Promise. See 374L<Server Push|https://tools.ietf.org/html/rfc7540#section-8.2> 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 402my @must_pp = (qw(:authority :method :path :scheme)); 403 404sub push { 405 my ( $self, %h ) = @_; 406 my $con = $self->{con}; 407 my @miss = grep { !exists $h{$_} } @must_pp; 408 croak "Missing headers in push promise: @miss" if @miss; 409 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 my $promised_sid = $con->new_stream; 414 $con->stream_promised_sid( $h{stream_id}, $promised_sid ); 415 416 my @headers = map { $_ => $h{$_} } @must_pp; 417 418 $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 $self->{cb}->( $promised_sid, \@headers ); 426 } 427 ); 428 429 return $self; 430} 431 432=head3 shutdown 433 434Get 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 446sub shutdown { 447 shift->{con}->shutdown; 448} 449 450=head3 next_frame 451 452get next frame to send over connection to client. 453Returns: 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 472sub next_frame { 473 my $self = shift; 474 my $frame = $self->{con}->dequeue; 475 if ($frame) { 476 my ( $length, $type, $flags, $stream_id ) = 477 $self->{con}->frame_header_decode( \$frame, 0 ); 478 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 return $frame; 485} 486 487=head3 feed 488 489Feed decoder with chunks of client's request 490 491 sysread $fh, $binary_data, 4096; 492 $server->feed($binary_data); 493 494=cut 495 496sub feed { 497 my ( $self, $chunk ) = @_; 498 $self->{input} .= $chunk; 499 my $offset = 0; 500 my $con = $self->{con}; 501 tracer->debug( "got " . length($chunk) . " bytes on a wire\n" ); 502 503 if ( $con->upgrade ) { 504 my @headers; 505 my $len = 506 $con->decode_upgrade_request( \$self->{input}, $offset, \@headers ); 507 $con->shutdown(1) unless defined $len; 508 return unless $len; 509 510 substr( $self->{input}, $offset, $len ) = ''; 511 512 $con->enqueue_raw( $con->upgrade_response ); 513 $con->enqueue( SETTINGS, 0, 0, 514 { 515 &SETTINGS_MAX_CONCURRENT_STREAMS => 516 DEFAULT_MAX_CONCURRENT_STREAMS 517 } 518 ); 519 $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 $con->new_peer_stream(1); 528 $con->stream_headers( 1, \@headers ); 529 $con->stream_state( 1, HALF_CLOSED ); 530 } 531 532 if ( !$con->preface ) { 533 my $len = $con->preface_decode( \$self->{input}, $offset ); 534 unless ( defined $len ) { 535 tracer->error("invalid preface. shutdown connection\n"); 536 $con->shutdown(1); 537 } 538 return unless $len; 539 tracer->debug("got preface\n"); 540 $offset += $len; 541 $con->preface(1); 542 } 543 544 while ( my $len = $con->frame_decode( \$self->{input}, $offset ) ) { 545 tracer->debug("decoded frame at $offset, length $len\n"); 546 $offset += $len; 547 } 548 substr( $self->{input}, 0, $offset ) = '' if $offset; 549} 550 551=head3 ping 552 553Send ping frame to client (to keep connection alive) 554 555 $server->ping 556 557or 558 559 $server->ping($payload); 560 561Payload can be arbitrary binary string and must contain 8 octets. If payload argument 562is omitted server will send random data. 563 564=cut 565 566sub ping { 567 shift->{con}->send_ping(@_); 568} 569 5701; 571