├── .gitignore ├── .travis.yml ├── Build.PL ├── Changes ├── LICENSE ├── META.json ├── README.md ├── cpanfile ├── examples ├── client-anyevent.pl ├── client-io-socket-ssl.pl ├── client-tls-anyevent.pl ├── extract_huff_codes.pl ├── extract_static_table.pl ├── server-anyevent.pl ├── server-io-socket-ssl.pl ├── server-tls-anyevent.pl ├── test.crt └── test.key ├── lib └── Protocol │ ├── HTTP2.pm │ └── HTTP2 │ ├── Client.pm │ ├── Connection.pm │ ├── Constants.pm │ ├── Frame.pm │ ├── Frame │ ├── Continuation.pm │ ├── Data.pm │ ├── Goaway.pm │ ├── Headers.pm │ ├── Ping.pm │ ├── Priority.pm │ ├── Push_promise.pm │ ├── Rst_stream.pm │ ├── Settings.pm │ └── Window_update.pm │ ├── HeaderCompression.pm │ ├── Huffman.pm │ ├── HuffmanCodes.pm │ ├── Server.pm │ ├── StaticTable.pm │ ├── Stream.pm │ ├── Trace.pm │ └── Upgrade.pm ├── minil.toml └── t ├── 00_compile.t ├── 01_HeaderCompression.t ├── 02_Huffman.t ├── 03_connection.t ├── 04_continuation.t ├── 05_trace.t ├── 06_upgrade.t ├── 07_ping.t ├── 08_priority.t ├── 09_client_server_tcp.t ├── 10_settings.t ├── 11_server_stream.t ├── 12_leaks.t ├── 13_request_with_body.t ├── 14_keepalive.t ├── continuation.request.data └── lib ├── PH2ClientServerTest.pm └── PH2Test.pm /.gitignore: -------------------------------------------------------------------------------- 1 | /.build/ 2 | /_build/ 3 | /Build 4 | /Build.bat 5 | /blib 6 | 7 | /carton.lock 8 | /.carton/ 9 | /local/ 10 | 11 | nytprof.out 12 | nytprof/ 13 | 14 | cover_db/ 15 | 16 | *.bak 17 | *.old 18 | *~ 19 | *.swp 20 | *.o 21 | *.obj 22 | 23 | !LICENSE 24 | 25 | /_build_params 26 | 27 | MYMETA.* 28 | 29 | /Protocol-HTTP2-* 30 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | perl: 3 | - 5.12 4 | - 5.14 5 | - 5.16 6 | - 5.18 7 | 8 | -------------------------------------------------------------------------------- /Build.PL: -------------------------------------------------------------------------------- 1 | # ========================================================================= 2 | # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. 3 | # DO NOT EDIT DIRECTLY. 4 | # ========================================================================= 5 | 6 | use 5.008_001; 7 | use strict; 8 | 9 | use Module::Build::Tiny 0.035; 10 | 11 | Build_PL(); 12 | 13 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for Perl extension Protocol-HTTP2 2 | 3 | {{$NEXT}} 4 | 5 | 1.11 2024-05-19T16:55:28Z 6 | - Fix minor typos and spelling errors (Yoshikazu Sawa) 7 | - Do not hardcode tlsv1 which is deprecated and disabled in some systems (Olivier Gayot) 8 | - Fix length-undef warnings in pre-5.12 perls (Felipe Gasper) 9 | 10 | 1.10 2019-11-12T06:19:05Z 11 | - test: fixed test 9 (issue 10) 12 | 13 | 1.09 2018-08-05T16:03:20Z 14 | - doc: fix spelling mistakes (Gregor Herrmann) 15 | - doc: added link to RFC 7541 (Mohammad S Anwar) 16 | - bugfix: protect against "disappearing" on_cancel() callback of 17 | server object (Felipe Gasper) 18 | - bugfix: prevent uninitialized warning (Junho Choi) 19 | 20 | 1.08 2016-09-27T12:57:26Z 21 | - implemented on_error callback for request 22 | - fixed bug: incorrect handling of negative window size (thanks to Daniil 23 | Bondarev for patch #2) 24 | - fixed bug: last chunk of blocked data can be sent several times 25 | - size of flow control window updated with current value of 26 | SETTINGS_INITIAL_WINDOW_SIZE 27 | 28 | 1.07 2016-03-03T20:44:19Z 29 | - implemented ping() method for client and server 30 | - implemented trailer headers support 31 | - fixed some error codes 32 | - improved header table size handling 33 | 34 | 1.06 2016-02-22T08:56:19Z 35 | - implemented keepalive option for client (#1) 36 | - explicit connection closing for client (#1) 37 | - fixed MAX_PAYLOAD_SIZE constant value (thanks to Francisco Obispo for 38 | bugreport) 39 | 40 | 1.05 2015-12-24T12:40:10Z 41 | - support for request body 42 | - new client/server examples with IO::Socket::SSL 43 | 44 | 1.04 2015-07-10T20:19:19Z 45 | - fixed bug: Chrome send ':path' as literal header, make exception for 46 | pseudo headers in header check 47 | - make exceptions for RST_STREAM frames in state_machine 48 | - fixed debugging level 49 | 50 | 1.03 2015-07-09T21:09:54Z 51 | - reworked enqueue() method, implemented enqueue_raw() 52 | - return error when CONTINUATION frames interrupted by other frames 53 | - check length of RST_STREAM and WINDOW_UPDATE frames 54 | - implemented validation rules for settings SETTINGS_ENABLE_PUSH and 55 | SETTINGS_INITIAL_WINDOW_SIZE 56 | - update flow control window size on active streams when receive 57 | SETTINGS_INITIAL_WINDOW_SIZE 58 | - fixed bug: now send ack on empty settings 59 | - fixed bug: flow control window for sended frames used to be initialized 60 | with wrong value 61 | - strict validation of headers 62 | - check for explicit content-length header to match size of received DATA 63 | frames 64 | - control for maximum concurrent streams 65 | - fixed tests 66 | 67 | 1.02 2015-06-22T17:27:01Z 68 | - fixed leaks test 69 | 70 | 1.01 2015-06-21T14:17:54Z 71 | - fixed leaks in Server/Client code 72 | - new test to check leaks 73 | - updated examples with tls 74 | 75 | 1.00 2015-05-16T18:51:09Z 76 | - HTTP/2 is RFC 7540 77 | - HPACK is RFC 7541 78 | - updated protocol id string ("h2", "h2c"), dropped old interop id strings 79 | 80 | 0.16 2015-04-05T20:41:49Z 81 | - update status (beta) 82 | - add wiki link 83 | - implemented server streaming 84 | - implemented client downloading, request cancelling 85 | 86 | 0.15 2015-02-26T20:39:20Z 87 | - Split settings for decoder/encoder 88 | - Allow to setup custom settings in Server/Client constructor 89 | - Fixed bug with settings packing/unpacking 90 | - Dropper Log::Dispatch dependency 91 | - updated HPACK to draft 12 92 | 93 | 0.14 2015-02-11T14:03:22Z 94 | - updated HTTP/2 to draft 17 95 | - updated HPACK to draft 11 96 | 97 | 0.13 2014-12-01T07:56:43Z 98 | - updated HTTP/2 to draft 16 99 | - added draft_interop version (14) for interoperability 100 | 101 | 0.12 2014-10-28T12:18:22Z 102 | - updated HTTP/2 to draft 15 103 | 104 | 0.11 2014-08-14T12:07:48Z 105 | - dropped Hash::MultiValue requirement 106 | - fixed HPACK 107 | - fixed HPACK test 108 | 109 | 0.10 2014-07-31T21:25:59Z 110 | - updated HTTP/2 to draft 14 111 | - updated HPACK to draft 09 112 | - fixed tests 113 | 114 | 0.09 2014-07-08T13:16:24Z 115 | 116 | - another fix for 09_client_server_tcp.t (check features of Net::SSLeay) 117 | - updated extract_* scripts 118 | - updated HTTP/2 to draft 13 119 | - removed ALTSVC and BLOCKED frames 120 | - removed DATA frames compression support 121 | - PAD_HIGH, PAD_LOW flags are replaced by PADDED 122 | - settings changed from 8-bit to 16-bit unsigned integer 123 | - updated HPACK to draft 08 124 | - updated huffman codes table 125 | - updated static table 126 | - fixed tests 127 | 128 | 0.08 2014-05-17T09:59:07Z 129 | 130 | - fixed test 09_client_server_tcp.t 131 | - fixed *_COMPRESS_DATA constants 132 | - fixed blocked data handling 133 | - allow zero-sized DATA frames 134 | - fixed HPACK encoding: evicting and reference set emptying 135 | - added Protocol::HTTP2::Server POD 136 | - fixed upgrade (added required header :scheme) 137 | 138 | 0.07 2014-05-15T13:14:32Z 139 | 140 | - implemented PRIOIRITY encoder/decoder 141 | - update HEADERS implementation (priority handling) 142 | - remove old flags PRIORITY_GROUP, PRIORITY_DEPENDENCY 143 | - added tcp test 144 | - update cpanfile (TCP::Test and other test deps) 145 | - implemented ALTSVC encoder/decoder 146 | - updated Protocol::HTTP2 POD 147 | - added Protocol::HTTP2::Client POD 148 | 149 | 0.06 2014-05-13T17:51:16Z 150 | 151 | - switch to Module::Build::Tiny 152 | - implemented PING encoder/decoder 153 | - fixed Rst_stream - unneeded state manipulation 154 | - internal PH2Test test module 155 | - implemented PUSH_PROMISE encoder 156 | - implemented push for Server 157 | - add Server's push in server-tls-anyevent.pl example 158 | - process state of encoded frame after putting it on a queue 159 | 160 | 0.05 2014-05-11T11:19:57Z 161 | 162 | - implemented flow control 163 | - implemented WINDOW_UPDATE encoder/decoder 164 | - fixed MAX_PAYLOAD_SIZE constant 165 | - fixed runtime error in RST_STREAM 166 | - required MIME::Base64 >= 3.11 (encode_base64url and decode_base64url) 167 | - HTTP/1.1 Upgrade for client 168 | 169 | 0.04 2014-05-08T18:22:24Z 170 | 171 | - enable Upgrade in server-anyevent.pl example 172 | - implemented HTTP/1.1 Upgrade (server) 173 | - fixed build/tests on windows 174 | - update cpanfile (Net::SSLeay > 1.45 for NPN) 175 | - update state doc 176 | 177 | 0.03 2014-05-07T18:05:50Z 178 | 179 | - client-tls-anyevent.pl with NPN/ALPN support and server's push handling 180 | - fixed error handling (send only one GOAWAY) 181 | - fixed PUSH_RPOMISE/CONTINUATION state and headers handling 182 | - implemented PUSH_PROMISE decoder 183 | - implemented RST_STREAM encoder 184 | - server-tls-anyevent.pl with NPN/ALPN support 185 | - fixed Connection's send(): set END_STREAM flag for last DATA frame 186 | - fixed HEADERS/CONTINUATION logic 187 | - pending state change until all CONTINUATION frames received 188 | - fixed author 189 | 190 | 0.02 2014-05-05T20:24:31Z 191 | 192 | - implemented CONTINUATION frame decoding 193 | - docs: table about frame types, flags and stream id 194 | 195 | 0.01 2014-04-27T08:51:15Z 196 | 197 | - original version 198 | 199 | -------------------------------------------------------------------------------- /META.json: -------------------------------------------------------------------------------- 1 | { 2 | "abstract" : "HTTP/2 protocol implementation (RFC 7540)", 3 | "author" : [ 4 | "Vladimir Lettiev " 5 | ], 6 | "dynamic_config" : 0, 7 | "generated_by" : "Minilla/v3.1.21, CPAN::Meta::Converter version 2.150010", 8 | "license" : [ 9 | "perl_5" 10 | ], 11 | "meta-spec" : { 12 | "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", 13 | "version" : 2 14 | }, 15 | "name" : "Protocol-HTTP2", 16 | "no_index" : { 17 | "directory" : [ 18 | "t", 19 | "xt", 20 | "inc", 21 | "share", 22 | "eg", 23 | "examples", 24 | "author", 25 | "builder" 26 | ] 27 | }, 28 | "prereqs" : { 29 | "configure" : { 30 | "requires" : { 31 | "Module::Build::Tiny" : "0.035" 32 | } 33 | }, 34 | "develop" : { 35 | "requires" : { 36 | "AnyEvent" : "0", 37 | "Net::SSLeay" : "> 1.45", 38 | "Test::CPAN::Meta" : "0", 39 | "Test::MinimumVersion::Fast" : "0.04", 40 | "Test::PAUSE::Permissions" : "0.07", 41 | "Test::Pod" : "1.41", 42 | "Test::Spellunker" : "v0.2.7", 43 | "XML::LibXML" : "0" 44 | } 45 | }, 46 | "runtime" : { 47 | "requires" : { 48 | "MIME::Base64" : "3.11", 49 | "Scalar::Util" : "0", 50 | "perl" : "5.008005" 51 | } 52 | }, 53 | "test" : { 54 | "requires" : { 55 | "AnyEvent" : "0", 56 | "Net::SSLeay" : "> 1.45", 57 | "Test::LeakTrace" : "0", 58 | "Test::More" : "0.98", 59 | "Test::TCP" : "0" 60 | } 61 | } 62 | }, 63 | "release_status" : "unstable", 64 | "resources" : { 65 | "bugtracker" : { 66 | "web" : "https://github.com/vlet/p5-Protocol-HTTP2/issues" 67 | }, 68 | "homepage" : "https://github.com/vlet/p5-Protocol-HTTP2", 69 | "repository" : { 70 | "type" : "git", 71 | "url" : "https://github.com/vlet/p5-Protocol-HTTP2.git", 72 | "web" : "https://github.com/vlet/p5-Protocol-HTTP2" 73 | } 74 | }, 75 | "version" : "1.11", 76 | "x_contributors" : [ 77 | "Daniil Bondarev ", 78 | "Felipe Gasper ", 79 | "Junho Choi ", 80 | "Mohammad S Anwar ", 81 | "Olivier Gayot ", 82 | "gregor herrmann ", 83 | "yoshikazusawa <883514+yoshikazusawa@users.noreply.github.com>" 84 | ], 85 | "x_serialization_backend" : "JSON::PP version 4.07", 86 | "x_static_install" : 1 87 | } 88 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | Protocol::HTTP2 - HTTP/2 protocol implementation (RFC 7540) 4 | 5 | # SYNOPSIS 6 | 7 | use Protocol::HTTP2; 8 | 9 | # get protocol identification string for secure connections 10 | print Protocol::HTTP2::ident_tls; # h2 11 | 12 | # get protocol identification string for non-secure connections 13 | print Protocol::HTTP2::ident_plain; # h2c 14 | 15 | # DESCRIPTION 16 | 17 | Protocol::HTTP2 is HTTP/2 protocol implementation ([RFC 7540](https://tools.ietf.org/html/rfc7540)) with stateful 18 | decoders/encoders of HTTP/2 frames. You may use this module to implement your 19 | own HTTP/2 client/server/intermediate on top of your favorite event loop over 20 | plain or tls socket (see examples). 21 | 22 | # STATUS 23 | 24 | Current status - beta. Structures, module names and methods seems like stable. 25 | I've started this project to understand internals of HTTP/2 and may be it will 26 | never become production, but at least it works. 27 | 28 | | Spec | status | 29 | | ----------------------- | --------------- | 30 | | Negotiation | ALPN, NPN, | 31 | | | Upgrade, direct | 32 | | Preface | + | 33 | | Headers (de)compression | + | 34 | | Stream states | + | 35 | | Flow control | ± | 36 | | Stream priority | ± | 37 | | Server push | + | 38 | | Connect method | - | 39 | 40 | 41 | | Frame | encoder | decoder | 42 | | --------------- |:-------:|:-------:| 43 | | DATA | ± | + | 44 | | HEADERS | + | + | 45 | | PRIORITY | + | + | 46 | | RST_STREAM | + | + | 47 | | SETTINGS | + | + | 48 | | PUSH_PROMISE | + | + | 49 | | PING | + | + | 50 | | GOAWAY | + | + | 51 | | WINDOW_UPDATE | + | + | 52 | | CONTINUATION | ± | + | 53 | 54 | - - -- not implemented 55 | - ± -- incomplete 56 | - + -- implemented (may even work) 57 | 58 | # MODULES 59 | 60 | ## [Protocol::HTTP2::Client](https://metacpan.org/pod/Protocol%3A%3AHTTP2%3A%3AClient) 61 | 62 | Client protocol decoder/encoder with constructor of requests 63 | 64 | ## [Protocol::HTTP2::Server](https://metacpan.org/pod/Protocol%3A%3AHTTP2%3A%3AServer) 65 | 66 | Server protocol decoder/encoder with constructor of responses/pushes 67 | 68 | ## [Protocol::HTTP2::Connection](https://metacpan.org/pod/Protocol%3A%3AHTTP2%3A%3AConnection) 69 | 70 | Main low level module for protocol logic and state processing. Connection 71 | object is a mixin of [Protocol::HTTP2::Frame](https://metacpan.org/pod/Protocol%3A%3AHTTP2%3A%3AFrame) (frame encoding/decoding), 72 | [Protocol::HTTP2::Stream](https://metacpan.org/pod/Protocol%3A%3AHTTP2%3A%3AStream) (stream operations) and [Protocol::HTTP2::Upgrade](https://metacpan.org/pod/Protocol%3A%3AHTTP2%3A%3AUpgrade) 73 | (HTTP/1.1 Upgrade support) 74 | 75 | ## [Protocol::HTTP2::HeaderCompression](https://metacpan.org/pod/Protocol%3A%3AHTTP2%3A%3AHeaderCompression) 76 | 77 | Module implements HPACK - Header Compression for HTTP/2 ([RFC 7541](https://tools.ietf.org/html/rfc7541)). 78 | 79 | ## [Protocol::HTTP2::Constants](https://metacpan.org/pod/Protocol%3A%3AHTTP2%3A%3AConstants) 80 | 81 | Module contains all defined in HTTP/2 protocol constants and default values 82 | 83 | ## [Protocol::HTTP2::Trace](https://metacpan.org/pod/Protocol%3A%3AHTTP2%3A%3ATrace) 84 | 85 | Module for debugging. You can setup HTTP2\_DEBUG environment variable to change 86 | verbosity of the module (output to STDOUT). Default level is error. 87 | 88 | $ export HTTP2_DEBUG=debug 89 | $ perl ./http2_program 90 | 91 | # SEE ALSO 92 | 93 | [https://github.com/vlet/p5-Protocol-HTTP2/wiki](https://github.com/vlet/p5-Protocol-HTTP2/wiki) - Protocol::HTTP2 wiki 94 | 95 | [http://http2.github.io/](http://http2.github.io/) - official HTTP/2 specification site 96 | 97 | [http://daniel.haxx.se/http2/](http://daniel.haxx.se/http2/) - http2 explained 98 | 99 | # LICENSE 100 | 101 | Copyright (C) Vladimir Lettiev. 102 | 103 | This library is free software; you can redistribute it and/or modify 104 | it under the same terms as Perl itself. 105 | 106 | # AUTHOR 107 | 108 | Vladimir Lettiev 109 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'perl', '5.008001'; 2 | 3 | # (encode,decode)_base64url 4 | requires 'MIME::Base64', '3.11'; 5 | 6 | # weaken 7 | requires 'Scalar::Util'; 8 | 9 | on 'test' => sub { 10 | requires 'Test::More', '0.98'; 11 | requires 'AnyEvent'; 12 | requires 'Net::SSLeay', '> 1.45'; 13 | requires 'Test::TCP'; 14 | requires 'Test::LeakTrace'; 15 | }; 16 | 17 | on 'develop' => sub { 18 | requires 'XML::LibXML'; 19 | requires 'AnyEvent'; 20 | requires 'Net::SSLeay', '> 1.45'; 21 | }; 22 | -------------------------------------------------------------------------------- /examples/client-anyevent.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use AnyEvent; 4 | use AnyEvent::Socket; 5 | use AnyEvent::Handle; 6 | 7 | use Protocol::HTTP2::Client; 8 | use Protocol::HTTP2::Constants qw(const_name); 9 | 10 | my $client = Protocol::HTTP2::Client->new( 11 | on_change_state => sub { 12 | my ( $stream_id, $previous_state, $current_state ) = @_; 13 | printf "Stream %i changed state from %s to %s\n", 14 | $stream_id, const_name( "states", $previous_state ), 15 | const_name( "states", $current_state ); 16 | }, 17 | on_error => sub { 18 | my $error = shift; 19 | printf "Error occurred: %s\n", const_name( "errors", $error ); 20 | }, 21 | 22 | # Perform HTTP/1.1 Upgrade 23 | upgrade => 1, 24 | ); 25 | 26 | my $host = '127.0.0.1'; 27 | my $port = 8000; 28 | 29 | # Prepare http/2 request 30 | $client->request( 31 | ':scheme' => "http", 32 | ':authority' => $host . ":" . $port, 33 | ':path' => "/minil.toml", 34 | ':method' => "GET", 35 | headers => [ 36 | 'accept' => '*/*', 37 | 'user-agent' => 'perl-Protocol-HTTP2/0.01', 38 | ], 39 | on_done => sub { 40 | my ( $headers, $data ) = @_; 41 | printf "Get headers. Count: %i\n", scalar(@$headers) / 2; 42 | printf "Get data. Length: %i\n", length($data); 43 | print $data; 44 | }, 45 | ); 46 | 47 | my $w = AnyEvent->condvar; 48 | 49 | tcp_connect $host, $port, sub { 50 | my ($fh) = @_ or die "connection failed: $!"; 51 | my $handle; 52 | $handle = AnyEvent::Handle->new( 53 | fh => $fh, 54 | autocork => 1, 55 | on_error => sub { 56 | $_[0]->destroy; 57 | print "connection error\n"; 58 | $w->send; 59 | }, 60 | on_eof => sub { 61 | $handle->destroy; 62 | $w->send; 63 | } 64 | ); 65 | 66 | # First write preface to peer 67 | while ( my $frame = $client->next_frame ) { 68 | $handle->push_write($frame); 69 | } 70 | 71 | $handle->on_read( 72 | sub { 73 | my $handle = shift; 74 | 75 | $client->feed( $handle->{rbuf} ); 76 | 77 | $handle->{rbuf} = undef; 78 | while ( my $frame = $client->next_frame ) { 79 | $handle->push_write($frame); 80 | } 81 | $handle->push_shutdown if $client->shutdown; 82 | } 83 | ); 84 | }; 85 | 86 | $w->recv; 87 | 88 | -------------------------------------------------------------------------------- /examples/client-io-socket-ssl.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Protocol::HTTP2::Client; 5 | use IO::Socket::SSL; 6 | use IO::Select; 7 | 8 | my $host = 'example.com'; 9 | my $port = 443; 10 | 11 | # POST request 12 | my $h2_client = Protocol::HTTP2::Client->new->request( 13 | 14 | # HTTP/2-headers 15 | ':method' => 'POST', 16 | ':path' => '/api/datas', 17 | ':scheme' => 'https', 18 | ':authority' => $host . ':' . $port, 19 | 20 | # HTTP-headers 21 | headers => [ 22 | 'user-agent' => 'Protocol::HTTP2', 23 | 'content-type' => 'application/json' 24 | ], 25 | 26 | # do something useful with data 27 | on_done => sub { 28 | my ( $headers, $data ) = @_; 29 | 30 | }, 31 | 32 | # POST body 33 | data => '{ "data" : "test" }', 34 | ); 35 | 36 | # TLS transport socket 37 | my $client = IO::Socket::SSL->new( 38 | PeerHost => $host, 39 | PeerPort => $port, 40 | 41 | # openssl 1.0.1 support only NPN 42 | SSL_npn_protocols => ['h2'], 43 | 44 | # openssl 1.0.2 also have ALPN 45 | #SSL_alpn_protocols => ['h2'], 46 | ) or die $!; 47 | 48 | # non blocking 49 | $client->blocking(0); 50 | 51 | my $sel = IO::Select->new($client); 52 | 53 | # send/recv frames until request is done 54 | while ( !$h2_client->shutdown ) { 55 | $sel->can_write; 56 | while ( my $frame = $h2_client->next_frame ) { 57 | syswrite $client, $frame; 58 | } 59 | 60 | $sel->can_read; 61 | while ( sysread $client, my $data, 4096 ) { 62 | $h2_client->feed($data); 63 | } 64 | } 65 | 66 | -------------------------------------------------------------------------------- /examples/client-tls-anyevent.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use AnyEvent; 4 | use AnyEvent::Socket; 5 | use AnyEvent::Handle; 6 | use Net::SSLeay; 7 | use AnyEvent::TLS; 8 | 9 | use Protocol::HTTP2; 10 | use Protocol::HTTP2::Client; 11 | use Protocol::HTTP2::Constants qw(const_name); 12 | 13 | Net::SSLeay::initialize(); 14 | 15 | my $client = Protocol::HTTP2::Client->new( 16 | on_change_state => sub { 17 | my ( $stream_id, $previous_state, $current_state ) = @_; 18 | printf "Stream %i changed state from %s to %s\n", 19 | $stream_id, const_name( "states", $previous_state ), 20 | const_name( "states", $current_state ); 21 | }, 22 | on_push => sub { 23 | my ($push_headers) = @_; 24 | 25 | # If we accept PUSH_PROMISE 26 | # return callback to receive promised data 27 | # return undef otherwise 28 | print "Server want to push some resource to us\n"; 29 | 30 | return sub { 31 | my ( $headers, $data ) = @_; 32 | print "Received promised resource\n"; 33 | } 34 | }, 35 | on_error => sub { 36 | my $error = shift; 37 | printf "Error occurred: %s\n", const_name( "errors", $error ); 38 | } 39 | ); 40 | 41 | my $host = '127.0.0.1'; 42 | my $port = 8000; 43 | 44 | # Prepare http/2 request 45 | $client->request( 46 | ':scheme' => "https", 47 | ':authority' => $host . ":" . $port, 48 | ':path' => "/minil.toml", 49 | ':method' => "GET", 50 | headers => [ 51 | 'accept' => '*/*', 52 | 'user-agent' => 'perl-Protocol-HTTP2/0.01', 53 | ], 54 | on_done => sub { 55 | my ( $headers, $data ) = @_; 56 | printf "Get headers. Count: %i\n", scalar(@$headers) / 2; 57 | printf "Get data. Length: %i\n", length($data); 58 | print $data; 59 | }, 60 | ); 61 | 62 | my $w = AnyEvent->condvar; 63 | 64 | tcp_connect $host, $port, sub { 65 | my ($fh) = @_ or do { 66 | print "connection failed: $!\n"; 67 | $w->send; 68 | return; 69 | }; 70 | 71 | my $tls; 72 | eval { 73 | $tls = AnyEvent::TLS->new( method => "TLSv1_2", ); 74 | 75 | # ALPN (Net-SSLeay > 1.55, openssl >= 1.0.2) 76 | if ( exists &Net::SSLeay::CTX_set_alpn_protos ) { 77 | Net::SSLeay::CTX_set_alpn_protos( $tls->ctx, 78 | [Protocol::HTTP2::ident_tls] ); 79 | } 80 | 81 | # NPN (Net-SSLeay > 1.45, openssl >= 1.0.1) 82 | elsif ( exists &Net::SSLeay::CTX_set_next_proto_select_cb ) { 83 | Net::SSLeay::CTX_set_next_proto_select_cb( $tls->ctx, 84 | [Protocol::HTTP2::ident_tls] ); 85 | } 86 | else { 87 | die "ALPN and NPN is not supported\n"; 88 | } 89 | }; 90 | if ($@) { 91 | print "Some problem with SSL CTX: $@\n"; 92 | $w->send; 93 | return; 94 | } 95 | 96 | my $handle; 97 | $handle = AnyEvent::Handle->new( 98 | fh => $fh, 99 | tls => "connect", 100 | tls_ctx => $tls, 101 | autocork => 1, 102 | on_error => sub { 103 | $_[0]->destroy; 104 | print "connection error\n"; 105 | $w->send; 106 | }, 107 | on_eof => sub { 108 | $handle->destroy; 109 | $w->send; 110 | } 111 | ); 112 | 113 | # First write preface to peer 114 | while ( my $frame = $client->next_frame ) { 115 | $handle->push_write($frame); 116 | } 117 | 118 | $handle->on_read( 119 | sub { 120 | my $handle = shift; 121 | 122 | $client->feed( $handle->{rbuf} ); 123 | 124 | $handle->{rbuf} = undef; 125 | while ( my $frame = $client->next_frame ) { 126 | $handle->push_write($frame); 127 | } 128 | $handle->push_shutdown if $client->shutdown; 129 | } 130 | ); 131 | }; 132 | 133 | $w->recv; 134 | -------------------------------------------------------------------------------- /examples/extract_huff_codes.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # 3 | use strict; 4 | use warnings; 5 | 6 | use XML::LibXML; 7 | 8 | sub usage { 9 | "Usage: $0 draft-ietf-httpbis-header-compression.xml\n"; 10 | } 11 | 12 | my $file = $ARGV[0] or die usage; 13 | die usage unless -f $file; 14 | 15 | open my $fh, '<', $file or die $!; 16 | my $doc = XML::LibXML->load_xml( IO => $fh ); 17 | my $hufftable = 18 | XML::LibXML::XPathExpression->new( 19 | '//section[@title="Huffman Code"]//artwork'); 20 | my $value = $doc->findvalue($hufftable); 21 | die "cant find Huffman Codes section" unless $value; 22 | 23 | print << 'EOF'; 24 | package Protocol::HTTP2::HuffmanCodes; 25 | use strict; 26 | use warnings; 27 | require Exporter; 28 | our @ISA = qw(Exporter); 29 | our ( %hcodes, %rhcodes, $hre ); 30 | our @EXPORT = qw(%hcodes %rhcodes $hre); 31 | 32 | %hcodes = ( 33 | EOF 34 | 35 | for ( split /\n/, $value ) { 36 | my ( $code, $hex, $bit ) = (/\((.{3})\).+\s([0-9a-f]+)\s+\[\s*(\d+)\]/) 37 | or next; 38 | printf " %3d => '%0${bit}b',\n", $code, hex($hex); 39 | } 40 | 41 | print << 'EOF'; 42 | ); 43 | 44 | %rhcodes = reverse %hcodes; 45 | 46 | { 47 | local $" = '|'; 48 | $hre = qr/(?:^|\G)(@{[ keys %rhcodes ]})/; 49 | } 50 | 51 | 1; 52 | EOF 53 | 54 | -------------------------------------------------------------------------------- /examples/extract_static_table.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/perl 2 | # 3 | use strict; 4 | use warnings; 5 | 6 | use XML::LibXML; 7 | 8 | sub usage { 9 | "Usage: $0 draft-ietf-httpbis-header-compression.xml\n"; 10 | } 11 | 12 | my $file = $ARGV[0] or die usage; 13 | die usage unless -f $file; 14 | 15 | open my $fh, '<', $file or die $!; 16 | my $doc = XML::LibXML->load_xml( IO => $fh ); 17 | my $stattable = 18 | XML::LibXML::XPathExpression->new( 19 | '//texttable[@title="Static Table Entries"]/c'); 20 | my @nodes = $doc->findnodes($stattable); 21 | 22 | print <<'EOF'; 23 | package Protocol::HTTP2::StaticTable; 24 | use strict; 25 | use warnings; 26 | require Exporter; 27 | our @ISA = qw(Exporter); 28 | our ( @stable, %rstable ); 29 | our @EXPORT = qw(@stable %rstable); 30 | 31 | @stable = ( 32 | EOF 33 | 34 | while (@nodes) { 35 | my ( $idx, $name, $value ) = map { $_->textContent } splice( @nodes, 0, 3 ); 36 | last unless $idx; 37 | printf qq{ [ "%s", "%s" ],\n}, $name, $value; 38 | } 39 | 40 | print <<'EOF'; 41 | ); 42 | 43 | for my $k ( 0 .. $#stable ) { 44 | my $key = join ' ', @{ $stable[$k] }; 45 | $rstable{$key} = $k + 1; 46 | $rstable{ $stable[$k]->[0] . ' ' } = $k + 1 47 | if ( $stable[$k]->[1] ne '' 48 | && !exists $rstable{ $stable[$k]->[0] . ' ' } ); 49 | } 50 | 51 | 1; 52 | EOF 53 | -------------------------------------------------------------------------------- /examples/server-anyevent.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use AnyEvent; 4 | use AnyEvent::Socket; 5 | use AnyEvent::Handle; 6 | 7 | use Protocol::HTTP2::Server; 8 | use Protocol::HTTP2::Constants qw(const_name); 9 | 10 | my $host = '127.0.0.1'; 11 | my $port = 8000; 12 | 13 | my $w = AnyEvent->condvar; 14 | 15 | tcp_server $host, $port, sub { 16 | my ( $fh, $host, $port ) = @_; 17 | my $handle; 18 | $handle = AnyEvent::Handle->new( 19 | fh => $fh, 20 | autocork => 1, 21 | on_error => sub { 22 | $_[0]->destroy; 23 | print "connection error\n"; 24 | }, 25 | on_eof => sub { 26 | $handle->destroy; 27 | } 28 | ); 29 | 30 | my $server; 31 | $server = Protocol::HTTP2::Server->new( 32 | on_change_state => sub { 33 | my ( $stream_id, $previous_state, $current_state ) = @_; 34 | printf "Stream %i changed state from %s to %s\n", 35 | $stream_id, const_name( "states", $previous_state ), 36 | const_name( "states", $current_state ); 37 | }, 38 | on_error => sub { 39 | my $error = shift; 40 | printf "Error occurred: %s\n", const_name( "errors", $error ); 41 | }, 42 | on_request => sub { 43 | my ( $stream_id, $headers, $data ) = @_; 44 | my $message = "hello, world!"; 45 | $server->response( 46 | ':status' => 200, 47 | stream_id => $stream_id, 48 | headers => [ 49 | 'server' => 'perl-Protocol-HTTP2/0.01', 50 | 'content-length' => length($message), 51 | 'cache-control' => 'max-age=3600', 52 | 'date' => 'Fri, 18 Apr 2014 07:27:11 GMT', 53 | 'last-modified' => 'Thu, 27 Feb 2014 10:30:37 GMT', 54 | ], 55 | data => $message, 56 | ); 57 | }, 58 | 59 | # Accept HTTP/1.1 Upgrade header 60 | upgrade => 1, 61 | ); 62 | 63 | # First send settings to peer 64 | while ( my $frame = $server->next_frame ) { 65 | $handle->push_write($frame); 66 | } 67 | 68 | $handle->on_read( 69 | sub { 70 | my $handle = shift; 71 | 72 | $server->feed( $handle->{rbuf} ); 73 | 74 | $handle->{rbuf} = undef; 75 | while ( my $frame = $server->next_frame ) { 76 | $handle->push_write($frame); 77 | } 78 | $handle->push_shutdown if $server->shutdown; 79 | } 80 | ); 81 | }; 82 | 83 | $w->recv; 84 | 85 | -------------------------------------------------------------------------------- /examples/server-io-socket-ssl.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use IO::Select; 4 | use IO::Socket::SSL; 5 | use Protocol::HTTP2::Server; 6 | 7 | # TLS transport socket 8 | my $srv = IO::Socket::SSL->new( 9 | LocalAddr => '0.0.0.0:4443', 10 | Listen => 10, 11 | SSL_cert_file => 'test.crt', 12 | SSL_key_file => 'test.key', 13 | 14 | # openssl 1.0.1 support only NPN 15 | SSL_npn_protocols => ['h2'], 16 | 17 | # openssl 1.0.2 also have ALPN 18 | #SSL_alpn_protocols => ['h2'], 19 | ) or die $!; 20 | 21 | # Accept client connection 22 | while ( my $client = $srv->accept ) { 23 | 24 | # HTTP/2 server 25 | my $h2_srv; 26 | $h2_srv = Protocol::HTTP2::Server->new( 27 | on_request => sub { 28 | my ( $stream_id, $headers, $data ) = @_; 29 | $h2_srv->response( 30 | ':status' => 200, 31 | stream_id => $stream_id, 32 | headers => [ 33 | 'server' => 'Protocol::HTTP2::Server', 34 | 'content-type' => 'application/json', 35 | ], 36 | data => '{ "hello" : "world" }', 37 | ); 38 | } 39 | ); 40 | 41 | # non-blocking 42 | $client->blocking(0); 43 | my $sel = IO::Select->new($client); 44 | 45 | # send/recv frames until request/response is done 46 | while ( !$h2_srv->shutdown ) { 47 | $sel->can_write; 48 | while ( my $frame = $h2_srv->next_frame ) { 49 | syswrite $client, $frame; 50 | } 51 | 52 | $sel->can_read; 53 | my $len; 54 | while ( my $rd = sysread $client, my $data, 4096 ) { 55 | $h2_srv->feed($data); 56 | $len += $rd; 57 | } 58 | 59 | # check if client disconnects 60 | last unless $len; 61 | } 62 | 63 | # destroy server object 64 | undef $h2_srv; 65 | } 66 | 67 | -------------------------------------------------------------------------------- /examples/server-tls-anyevent.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use AnyEvent; 4 | use AnyEvent::Socket; 5 | use AnyEvent::Handle; 6 | use Net::SSLeay; 7 | use AnyEvent::TLS; 8 | 9 | use Protocol::HTTP2; 10 | use Protocol::HTTP2::Server; 11 | use Protocol::HTTP2::Constants qw(const_name); 12 | 13 | Net::SSLeay::initialize(); 14 | 15 | my $host = '127.0.0.1'; 16 | my $port = 8000; 17 | 18 | my $w = AnyEvent->condvar; 19 | 20 | tcp_server $host, $port, sub { 21 | my ( $fh, $host, $port ) = @_; 22 | my $handle; 23 | 24 | my $tls; 25 | eval { 26 | $tls = AnyEvent::TLS->new( 27 | method => "TLSv1_2", 28 | cert_file => "test.crt", 29 | key_file => "test.key", 30 | ); 31 | 32 | # ECDH curve ( Net-SSLeay >= 1.56, openssl >= 1.0.0 ) 33 | if ( exists &Net::SSLeay::CTX_set_tmp_ecdh ) { 34 | my $curve = Net::SSLeay::OBJ_txt2nid('prime256v1'); 35 | my $ecdh = Net::SSLeay::EC_KEY_new_by_curve_name($curve); 36 | Net::SSLeay::CTX_set_tmp_ecdh( $tls->ctx, $ecdh ); 37 | Net::SSLeay::EC_KEY_free($ecdh); 38 | } 39 | 40 | # ALPN (Net-SSLeay > 1.55, openssl >= 1.0.2) 41 | if ( exists &Net::SSLeay::CTX_set_alpn_select_cb ) { 42 | Net::SSLeay::CTX_set_alpn_select_cb( $tls->ctx, 43 | [Protocol::HTTP2::ident_tls] ); 44 | } 45 | 46 | # NPN (Net-SSLeay > 1.45, openssl >= 1.0.1) 47 | elsif ( exists &Net::SSLeay::CTX_set_next_protos_advertised_cb ) { 48 | Net::SSLeay::CTX_set_next_protos_advertised_cb( $tls->ctx, 49 | [Protocol::HTTP2::ident_tls] ); 50 | } 51 | else { 52 | die "ALPN and NPN is not supported\n"; 53 | } 54 | }; 55 | 56 | if ($@) { 57 | print "Some problem with SSL CTX: $@\n"; 58 | $w->send; 59 | return; 60 | } 61 | 62 | $handle = AnyEvent::Handle->new( 63 | fh => $fh, 64 | autocork => 1, 65 | tls => "accept", 66 | tls_ctx => $tls, 67 | on_error => sub { 68 | $_[0]->destroy; 69 | print "connection error\n"; 70 | }, 71 | on_eof => sub { 72 | $handle->destroy; 73 | } 74 | ); 75 | 76 | my $server; 77 | $server = Protocol::HTTP2::Server->new( 78 | on_change_state => sub { 79 | my ( $stream_id, $previous_state, $current_state ) = @_; 80 | printf "Stream %i changed state from %s to %s\n", 81 | $stream_id, const_name( "states", $previous_state ), 82 | const_name( "states", $current_state ); 83 | }, 84 | on_error => sub { 85 | my $error = shift; 86 | printf "Error occurred: %s\n", const_name( "errors", $error ); 87 | }, 88 | on_request => sub { 89 | my ( $stream_id, $headers, $data ) = @_; 90 | my %h = (@$headers); 91 | 92 | # Push promise (must be before response) 93 | if ( $h{':path'} eq '/minil.toml' ) { 94 | $server->push( 95 | ':authority' => $host . ':' . $port, 96 | ':method' => 'GET', 97 | ':path' => '/css/style.css', 98 | ':scheme' => 'https', 99 | stream_id => $stream_id, 100 | ); 101 | } 102 | 103 | my $message = "hello, world!"; 104 | $server->response( 105 | ':status' => 200, 106 | stream_id => $stream_id, 107 | headers => [ 108 | 'server' => 'perl-Protocol-HTTP2/0.01', 109 | 'content-length' => length($message), 110 | 'cache-control' => 'max-age=3600', 111 | 'date' => 'Fri, 18 Apr 2014 07:27:11 GMT', 112 | 'last-modified' => 'Thu, 27 Feb 2014 10:30:37 GMT', 113 | ], 114 | data => $message, 115 | ); 116 | }, 117 | ); 118 | 119 | # First send settings to peer 120 | while ( my $frame = $server->next_frame ) { 121 | $handle->push_write($frame); 122 | } 123 | 124 | $handle->on_read( 125 | sub { 126 | my $handle = shift; 127 | 128 | $server->feed( $handle->{rbuf} ); 129 | 130 | $handle->{rbuf} = undef; 131 | while ( my $frame = $server->next_frame ) { 132 | $handle->push_write($frame); 133 | } 134 | $handle->push_shutdown if $server->shutdown; 135 | } 136 | ); 137 | }; 138 | 139 | $w->recv; 140 | -------------------------------------------------------------------------------- /examples/test.crt: -------------------------------------------------------------------------------- 1 | -----BEGIN CERTIFICATE----- 2 | MIIDujCCAqKgAwIBAgIUQ+Tzss6ENkikX2v1lEThSAJAxawwDQYJKoZIhvcNAQEL 3 | BQAwbjELMAkGA1UEBhMCUlUxEDAOBgNVBAgMB0RlZmF1bHQxFTATBgNVBAcMDERl 4 | ZmF1bHQgQ2l0eTEQMA4GA1UECgwHRGVmYXVsdDEQMA4GA1UECwwHZGVmYXVsdDES 5 | MBAGA1UEAwwJMTI3LjAuMC4xMB4XDTE5MTAxNDE2NTg0MloXDTI5MTAxMTE2NTg0 6 | MlowbjELMAkGA1UEBhMCUlUxEDAOBgNVBAgMB0RlZmF1bHQxFTATBgNVBAcMDERl 7 | ZmF1bHQgQ2l0eTEQMA4GA1UECgwHRGVmYXVsdDEQMA4GA1UECwwHZGVmYXVsdDES 8 | MBAGA1UEAwwJMTI3LjAuMC4xMIIBIjANBgkqhkiG9w0BAQEFAAOCAQ8AMIIBCgKC 9 | AQEArHBqjSEvJg/jYlVgv24LXgkc5WQxGAtSE3R/YdK0wEygSmcQpTFA1WfHPfHn 10 | AaHHlZTClfDv7UWNQIwfYqedQJwKPse5NFITw/ig9gONsDxIlBdc5hIqdWuIBQ/l 11 | j2Z/j3GIkVe4+vw4pGd5BmiQg98xLkca0/BVLVyCm+65g1oyx1SI4X98TfD3wTKg 12 | /KSUzuPaxtiJFZAxh4ayu4Gmyb8TyKKLR9Ff1ePceqVR5egBR+z/PJdKRoQDdb11 13 | x62g3p6tGpPmm3lxP9ovpYZtJNHhH7h6+AP7prAf3qcHPmnLvRAgSDznMqpMLVdO 14 | /Za5lY1h3dCkOAUV6Nf2YV26+wIDAQABo1AwTjAdBgNVHQ4EFgQU2wAFWDmSgrR9 15 | 1uOlFtQG1V2/s8swHwYDVR0jBBgwFoAU2wAFWDmSgrR91uOlFtQG1V2/s8swDAYD 16 | VR0TBAUwAwEB/zANBgkqhkiG9w0BAQsFAAOCAQEAmIhRxatzArXRwQHndj8DLfuF 17 | UG3hPxr1MK2/ooSXHvQqZwJgUXRt92NisBPhtHzPxrh+yPxjHno51kSbihuZUcOI 18 | ksjICBROUhdqzqfPnCiFkxmOHzPFEfFqmi17IhQeyve63ABxZdkRZd8wxfP4Ekoj 19 | xM3k9nLE7Ud7SajGou6VJ0+kuDxovEgIrllvCVdkBkbl5ILBlsKeBEi/ncz+nmam 20 | zOFQ1M6Iw7bD1zi9K5H/KRuYnKpqxA539+N6fW+bA/wnW8DOLnEx+KUUx0Jt55su 21 | ot/qTiqmTw2dIm3CC2ypgBmTEfyGV3uHwMU/sVetSOeCagqSkY/I25hx5jC0Mg== 22 | -----END CERTIFICATE----- 23 | -------------------------------------------------------------------------------- /examples/test.key: -------------------------------------------------------------------------------- 1 | -----BEGIN RSA PRIVATE KEY----- 2 | MIIEogIBAAKCAQEArHBqjSEvJg/jYlVgv24LXgkc5WQxGAtSE3R/YdK0wEygSmcQ 3 | pTFA1WfHPfHnAaHHlZTClfDv7UWNQIwfYqedQJwKPse5NFITw/ig9gONsDxIlBdc 4 | 5hIqdWuIBQ/lj2Z/j3GIkVe4+vw4pGd5BmiQg98xLkca0/BVLVyCm+65g1oyx1SI 5 | 4X98TfD3wTKg/KSUzuPaxtiJFZAxh4ayu4Gmyb8TyKKLR9Ff1ePceqVR5egBR+z/ 6 | PJdKRoQDdb11x62g3p6tGpPmm3lxP9ovpYZtJNHhH7h6+AP7prAf3qcHPmnLvRAg 7 | SDznMqpMLVdO/Za5lY1h3dCkOAUV6Nf2YV26+wIDAQABAoIBADLxLvksgYJMFU+6 8 | i09iUidgp9G4zKwexAuNUghzOATLXls8oXU73Lxu4TSSnz0jLxQok2e6exbsgjM8 9 | chUyEUnCD2DGnhcv3Dj73YlwOU6EMKjXUhGB8lsn/lIIhTfc/vhAgSj28mXrV0xy 10 | aRWUlITwzdWvGeTczj0NZGRunQ2Jfrm/6hYsPe3W8HYETnU592p3gU0p+RB3XEaD 11 | MfsGdv9+lG3dUrly9vYxI2R1Ushec02zXut34iuqCTIwC9EFPwzoAL6XnY7047XO 12 | iXXZfBWMuSKOL9jfTJb5Q1aXnlhTpVlFyV4JhO/rgcfo801gJThqhDZIEZXigDuB 13 | j/dIsckCgYEA3lhih02pYLJiDis83g9OYchBlISDVh8zsSochkt/oiMI9MKhpb/6 14 | rjjqXB+G0TXZ9iJVT0/lXoCSFftN5qgdSjh4pNAaq2qKHd7ogv2Gi94cLWmCdLE8 15 | nKctQgvJB4Q+bBOBbcvl3I9oZQkdj1Ap09CHbWcSLLX9gOrlHBsGf40CgYEAxoo6 16 | X/VO1zu13KDbvyANbXoG/jN6+P1CAc0coW1KmI7j3zS8JS/BNxC8ZIcquvMupCe2 17 | Ya0cXdYMGMQAmJ27T35f7MfDymjEcx3ZmyUEwov4t7OFyk/VkN6dnIUX39yglPMt 18 | ossAfNj2EBYAc/l8/p7Tuk0JYxRw1MpN75dmHqcCgYANpFSfQpeS1D8J6YM5iKzh 19 | ePz1FNBOF2n/g7ruTnGNTCL/iXWLiuThjaJrdo+6BFjULjUXwaosCy1rZdjYvxXU 20 | +PQGALKyM743qPaRGucHa+BEtQWJDVrPrb4sIDb8XBPMY8H8L5dx2eao1E9Y/K0k 21 | TtYQU1OdJKliIIdgGxRh/QKBgEpYZqWaOWy1ilNU1RTLztto74dvBaSJSZddFFSK 22 | lX1tPH1PxQhzynlxReqrBuA8wgFscYpABbhJt/vqIYMExaht3UPQRkvcUXv9+Id1 23 | JEQpn/hCPF5W6NU313NOD3OfrW45ZaRpOgSGRhYd9wt2qEy8cvJ3eIVmmR3Fp8uJ 24 | OQ9PAoGAU5W2dENhzCEg3wNcdXCnna/YuV4UpmjIjDcZduSmZhjbzHP0sHI1uEe8 25 | fndBa+6Klf6mKo2S2DssNldhItUgu0SGNa6DVb7gh0i5X8gaJjj8vWPxtEzOPJhN 26 | 3/f0gdWjc2ZBy+a0rMoRiaDFQIokHjitiDR+P3Ct70b3/Il7QHs= 27 | -----END RSA PRIVATE KEY----- 28 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2; 2 | use 5.008005; 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = "1.11"; 7 | 8 | sub ident_plain { 9 | 'h2c'; 10 | } 11 | 12 | sub ident_tls { 13 | 'h2'; 14 | } 15 | 16 | 1; 17 | __END__ 18 | 19 | =encoding utf-8 20 | 21 | =head1 NAME 22 | 23 | Protocol::HTTP2 - HTTP/2 protocol implementation (RFC 7540) 24 | 25 | =head1 SYNOPSIS 26 | 27 | use Protocol::HTTP2; 28 | 29 | # get protocol identification string for secure connections 30 | print Protocol::HTTP2::ident_tls; # h2 31 | 32 | # get protocol identification string for non-secure connections 33 | print Protocol::HTTP2::ident_plain; # h2c 34 | 35 | =head1 DESCRIPTION 36 | 37 | Protocol::HTTP2 is HTTP/2 protocol implementation (L) with stateful 38 | decoders/encoders of HTTP/2 frames. You may use this module to implement your 39 | own HTTP/2 client/server/intermediate on top of your favorite event loop over 40 | plain or tls socket (see examples). 41 | 42 | =head1 STATUS 43 | 44 | Current status - beta. Structures, module names and methods seems like stable. 45 | I've started this project to understand internals of HTTP/2 and may be it will 46 | never become production, but at least it works. 47 | 48 | | Spec | status | 49 | | ----------------------- | --------------- | 50 | | Negotiation | ALPN, NPN, | 51 | | | Upgrade, direct | 52 | | Preface | + | 53 | | Headers (de)compression | + | 54 | | Stream states | + | 55 | | Flow control | ± | 56 | | Stream priority | ± | 57 | | Server push | + | 58 | | Connect method | - | 59 | 60 | 61 | | Frame | encoder | decoder | 62 | | --------------- |:-------:|:-------:| 63 | | DATA | ± | + | 64 | | HEADERS | + | + | 65 | | PRIORITY | + | + | 66 | | RST_STREAM | + | + | 67 | | SETTINGS | + | + | 68 | | PUSH_PROMISE | + | + | 69 | | PING | + | + | 70 | | GOAWAY | + | + | 71 | | WINDOW_UPDATE | + | + | 72 | | CONTINUATION | ± | + | 73 | 74 | 75 | =over 76 | 77 | =item - -- not implemented 78 | 79 | =item ± -- incomplete 80 | 81 | =item + -- implemented (may even work) 82 | 83 | =back 84 | 85 | =head1 MODULES 86 | 87 | =head2 L 88 | 89 | Client protocol decoder/encoder with constructor of requests 90 | 91 | =head2 L 92 | 93 | Server protocol decoder/encoder with constructor of responses/pushes 94 | 95 | =head2 L 96 | 97 | Main low level module for protocol logic and state processing. Connection 98 | object is a mixin of L (frame encoding/decoding), 99 | L (stream operations) and L 100 | (HTTP/1.1 Upgrade support) 101 | 102 | =head2 L 103 | 104 | Module implements HPACK - Header Compression for HTTP/2 (L). 105 | 106 | =head2 L 107 | 108 | Module contains all defined in HTTP/2 protocol constants and default values 109 | 110 | =head2 L 111 | 112 | Module for debugging. You can setup HTTP2_DEBUG environment variable to change 113 | verbosity of the module (output to STDOUT). Default level is error. 114 | 115 | $ export HTTP2_DEBUG=debug 116 | $ perl ./http2_program 117 | 118 | =head1 SEE ALSO 119 | 120 | L - Protocol::HTTP2 wiki 121 | 122 | L - official HTTP/2 specification site 123 | 124 | L - http2 explained 125 | 126 | =head1 LICENSE 127 | 128 | Copyright (C) Vladimir Lettiev. 129 | 130 | This library is free software; you can redistribute it and/or modify 131 | it under the same terms as Perl itself. 132 | 133 | =head1 AUTHOR 134 | 135 | Vladimir Lettiev Ethecrux@gmail.comE 136 | 137 | =cut 138 | 139 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Client.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Client; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Connection; 5 | use Protocol::HTTP2::Constants qw(:frame_types :flags :states :endpoints 6 | :errors); 7 | use Protocol::HTTP2::Trace qw(tracer); 8 | use Carp; 9 | use Scalar::Util (); 10 | 11 | =encoding utf-8 12 | 13 | =head1 NAME 14 | 15 | Protocol::HTTP2::Client - HTTP/2 client 16 | 17 | =head1 SYNOPSIS 18 | 19 | use Protocol::HTTP2::Client; 20 | 21 | # Create client object 22 | my $client = Protocol::HTTP2::Client->new; 23 | 24 | # Prepare first request 25 | $client->request( 26 | 27 | # HTTP/2 headers 28 | ':scheme' => 'http', 29 | ':authority' => 'localhost:8000', 30 | ':path' => '/', 31 | ':method' => 'GET', 32 | 33 | # HTTP/1.1 headers 34 | headers => [ 35 | 'accept' => '*/*', 36 | 'user-agent' => 'perl-Protocol-HTTP2/0.13', 37 | ], 38 | 39 | # Callback when receive server's response 40 | on_done => sub { 41 | my ( $headers, $data ) = @_; 42 | ... 43 | }, 44 | ); 45 | 46 | # Protocol::HTTP2 is just HTTP/2 protocol decoder/encoder 47 | # so you must create connection yourself 48 | 49 | use AnyEvent; 50 | use AnyEvent::Socket; 51 | use AnyEvent::Handle; 52 | my $w = AnyEvent->condvar; 53 | 54 | # Plain-text HTTP/2 connection 55 | tcp_connect 'localhost', 8000, sub { 56 | my ($fh) = @_ or die "connection failed: $!\n"; 57 | 58 | my $handle; 59 | $handle = AnyEvent::Handle->new( 60 | fh => $fh, 61 | autocork => 1, 62 | on_error => sub { 63 | $_[0]->destroy; 64 | print "connection error\n"; 65 | $w->send; 66 | }, 67 | on_eof => sub { 68 | $handle->destroy; 69 | $w->send; 70 | } 71 | ); 72 | 73 | # First write preface to peer 74 | while ( my $frame = $client->next_frame ) { 75 | $handle->push_write($frame); 76 | } 77 | 78 | # Receive servers frames 79 | # Reply to server 80 | $handle->on_read( 81 | sub { 82 | my $handle = shift; 83 | 84 | $client->feed( $handle->{rbuf} ); 85 | 86 | $handle->{rbuf} = undef; 87 | while ( my $frame = $client->next_frame ) { 88 | $handle->push_write($frame); 89 | } 90 | 91 | # Terminate connection if all done 92 | $handle->push_shutdown if $client->shutdown; 93 | } 94 | ); 95 | }; 96 | 97 | $w->recv; 98 | 99 | =head1 DESCRIPTION 100 | 101 | Protocol::HTTP2::Client is HTTP/2 client library. It's intended to make 102 | http2-client implementations on top of your favorite event-loop. 103 | 104 | =head2 METHODS 105 | 106 | =head3 new 107 | 108 | Initialize new client object 109 | 110 | my $client = Protocol::HTTP2::Client->new( %options ); 111 | 112 | Available options: 113 | 114 | =over 115 | 116 | =item on_push => sub {...} 117 | 118 | If server send push promise this callback will be invoked 119 | 120 | on_push => sub { 121 | # received PUSH PROMISE headers 122 | my $pp_header = shift; 123 | ... 124 | 125 | # if we want reject this push 126 | # return undef 127 | 128 | # if we want to accept pushed resource 129 | # return callback to receive data 130 | return sub { 131 | my ( $headers, $data ) = @_; 132 | ... 133 | } 134 | }, 135 | 136 | =item upgrade => 0|1 137 | 138 | Use HTTP/1.1 Upgrade to upgrade protocol from HTTP/1.1 to HTTP/2. Upgrade 139 | possible only on plain (non-tls) connection. Default value is 0. 140 | 141 | See 142 | L 143 | 144 | =item keepalive => 0|1 145 | 146 | Keep connection alive after requests. Default value is 0. Don't forget to 147 | explicitly call close method if set this to true. 148 | 149 | =item on_error => sub {...} 150 | 151 | Callback invoked on protocol errors 152 | 153 | on_error => sub { 154 | my $error = shift; 155 | ... 156 | }, 157 | 158 | =item on_change_state => sub {...} 159 | 160 | Callback invoked every time when http/2 streams change their state. 161 | See 162 | L 163 | 164 | on_change_state => sub { 165 | my ( $stream_id, $previous_state, $current_state ) = @_; 166 | ... 167 | }, 168 | 169 | =back 170 | 171 | =cut 172 | 173 | sub new { 174 | my ( $class, %opts ) = @_; 175 | my $self = { 176 | con => undef, 177 | input => '', 178 | active_streams => 0, 179 | keepalive => exists $opts{keepalive} 180 | ? delete $opts{keepalive} 181 | : 0, 182 | settings => exists $opts{settings} ? $opts{settings} : {}, 183 | }; 184 | 185 | if ( exists $opts{on_push} ) { 186 | Scalar::Util::weaken( my $self = $self ); 187 | 188 | my $cb = delete $opts{on_push}; 189 | $opts{on_new_peer_stream} = sub { 190 | my $stream_id = shift; 191 | my $pp_headers; 192 | $self->active_streams(+1); 193 | 194 | $self->{con}->stream_cb( 195 | $stream_id, 196 | RESERVED, 197 | sub { 198 | my $res = 199 | $cb->( $self->{con}->stream_pp_headers($stream_id) ); 200 | if ( $res && ref $cb eq 'CODE' ) { 201 | $self->{con}->stream_cb( 202 | $stream_id, 203 | CLOSED, 204 | sub { 205 | $res->( 206 | $self->{con}->stream_headers($stream_id), 207 | $self->{con}->stream_data($stream_id), 208 | ); 209 | $self->active_streams(-1); 210 | } 211 | ); 212 | } 213 | else { 214 | $self->{con} 215 | ->stream_error( $stream_id, REFUSED_STREAM ); 216 | $self->active_streams(-1); 217 | } 218 | } 219 | ); 220 | }; 221 | } 222 | 223 | $self->{con} = Protocol::HTTP2::Connection->new( CLIENT, %opts ); 224 | bless $self, $class; 225 | } 226 | 227 | sub active_streams { 228 | my $self = shift; 229 | my $add = shift || 0; 230 | $self->{active_streams} += $add; 231 | $self->{con}->finish 232 | unless $self->{active_streams} > 0 233 | || $self->{keepalive}; 234 | } 235 | 236 | =head3 request 237 | 238 | Prepare HTTP/2 request. 239 | 240 | $client->request( 241 | 242 | # HTTP/2 headers 243 | ':scheme' => 'http', 244 | ':authority' => 'localhost:8000', 245 | ':path' => '/items', 246 | ':method' => 'POST', 247 | 248 | # HTTP/1.1 headers 249 | headers => [ 250 | 'content-type' => 'application/x-www-form-urlencoded', 251 | 'user-agent' => 'perl-Protocol-HTTP2/0.06', 252 | ], 253 | 254 | # Callback when receive server's response 255 | on_done => sub { 256 | my ( $headers, $data ) = @_; 257 | ... 258 | }, 259 | 260 | # Callback when receive stream reset 261 | on_error => sub { 262 | my $error_code = shift; 263 | }, 264 | 265 | # Body of POST request 266 | data => "hello=world&test=done", 267 | ); 268 | 269 | You can chaining request one by one: 270 | 271 | $client->request( 1-st request )->request( 2-nd request ); 272 | 273 | Available callbacks: 274 | 275 | =over 276 | 277 | =item on_done => sub {...} 278 | 279 | Invoked when full servers response is available 280 | 281 | on_done => sub { 282 | my ( $headers, $data ) = @_; 283 | ... 284 | }, 285 | 286 | =item on_headers => sub {...} 287 | 288 | Invoked as soon as headers have been successfully received from the server 289 | 290 | on_headers => sub { 291 | my $headers = shift; 292 | ... 293 | 294 | # if we want reject any data 295 | # return undef 296 | 297 | # continue 298 | return 1 299 | } 300 | 301 | =item on_data => sub {...} 302 | 303 | If specified all data will be passed to this callback instead if on_done. 304 | on_done will receive empty string. 305 | 306 | on_data => sub { 307 | my ( $partial_data, $headers ) = @_; 308 | ... 309 | 310 | # if we want cancel download 311 | # return undef 312 | 313 | # continue downloading 314 | return 1 315 | } 316 | 317 | =item on_error => sub {...} 318 | 319 | Callback invoked on stream errors 320 | 321 | on_error => sub { 322 | my $error = shift; 323 | ... 324 | } 325 | 326 | =back 327 | 328 | =cut 329 | 330 | my @must = (qw(:authority :method :path :scheme)); 331 | 332 | sub request { 333 | my ( $self, %h ) = @_; 334 | my @miss = grep { !exists $h{$_} } @must; 335 | croak "Missing fields in request: @miss" if @miss; 336 | 337 | my $con = $self->{con}; 338 | 339 | my $stream_id = $con->new_stream; 340 | unless ( defined $stream_id ) { 341 | if ( exists $con->{on_error} ) { 342 | $con->{on_error}->(PROTOCOL_ERROR); 343 | return $self; 344 | } 345 | else { 346 | croak "Can't create new stream, connection is closed"; 347 | } 348 | } 349 | 350 | $self->active_streams(+1); 351 | 352 | if ( $con->upgrade && !exists $self->{sent_upgrade} ) { 353 | $con->enqueue_raw( 354 | $con->upgrade_request( 355 | ( map { $_ => $h{$_} } @must ), 356 | headers => exists $h{headers} ? $h{headers} : [] 357 | ) 358 | ); 359 | $self->{sent_upgrade} = 1; 360 | $con->stream_state( $stream_id, HALF_CLOSED ); 361 | } 362 | else { 363 | if ( !$con->preface ) { 364 | $con->enqueue_raw( $con->preface_encode ), 365 | $con->enqueue( SETTINGS, 0, 0, $self->{settings} ); 366 | $con->preface(1); 367 | } 368 | 369 | $con->send_headers( 370 | $stream_id, 371 | [ 372 | ( map { $_ => $h{$_} } @must ), 373 | exists $h{headers} ? @{ $h{headers} } : () 374 | ], 375 | exists $h{data} ? 0 : 1 376 | ); 377 | $con->send_data( $stream_id, $h{data}, 1 ) if exists $h{data}; 378 | } 379 | 380 | Scalar::Util::weaken $self; 381 | Scalar::Util::weaken $con; 382 | 383 | $con->stream_cb( 384 | $stream_id, 385 | CLOSED, 386 | sub { 387 | if ( exists $h{on_error} && $con->stream_reset($stream_id) ) { 388 | $h{on_error}->( $con->stream_reset($stream_id) ); 389 | } 390 | else { 391 | $h{on_done}->( 392 | $con->stream_headers($stream_id), 393 | $con->stream_data($stream_id), 394 | ); 395 | } 396 | $self->active_streams(-1); 397 | } 398 | ) if exists $h{on_done}; 399 | 400 | $con->stream_frame_cb( 401 | $stream_id, 402 | HEADERS, 403 | sub { 404 | my $res = $h{on_headers}->( $_[0] ); 405 | return if $res; 406 | $con->stream_error( $stream_id, REFUSED_STREAM ); 407 | } 408 | ) if exists $h{on_headers}; 409 | 410 | $con->stream_frame_cb( 411 | $stream_id, 412 | DATA, 413 | sub { 414 | my $res = $h{on_data}->( $_[0], $con->stream_headers($stream_id), ); 415 | return if $res; 416 | $con->stream_error( $stream_id, REFUSED_STREAM ); 417 | } 418 | ) if exists $h{on_data}; 419 | 420 | return $self; 421 | } 422 | 423 | =head3 keepalive 424 | 425 | Keep connection alive after requests 426 | 427 | my $bool = $client->keepalive; 428 | $client = $client->keepalive($bool); 429 | 430 | =cut 431 | 432 | sub keepalive { 433 | my $self = shift; 434 | return @_ 435 | ? scalar( $self->{keepalive} = shift, $self ) 436 | : $self->{keepalive}; 437 | } 438 | 439 | =head3 shutdown 440 | 441 | Get connection status: 442 | 443 | =over 444 | 445 | =item 0 - active 446 | 447 | =item 1 - closed (you can terminate connection) 448 | 449 | =back 450 | 451 | =cut 452 | 453 | sub shutdown { 454 | shift->{con}->shutdown; 455 | } 456 | 457 | =head3 close 458 | 459 | Explicitly close connection (send GOAWAY frame). This is required if client 460 | has keepalive option enabled. 461 | 462 | =cut 463 | 464 | sub close { 465 | shift->{con}->finish; 466 | } 467 | 468 | =head3 next_frame 469 | 470 | get next frame to send over connection to server. 471 | Returns: 472 | 473 | =over 474 | 475 | =item undef - on error 476 | 477 | =item 0 - nothing to send 478 | 479 | =item binary string - encoded frame 480 | 481 | =back 482 | 483 | # Example 484 | while ( my $frame = $client->next_frame ) { 485 | syswrite $fh, $frame; 486 | } 487 | 488 | =cut 489 | 490 | sub next_frame { 491 | my $self = shift; 492 | my $frame = $self->{con}->dequeue; 493 | tracer->debug("send one frame to wire\n") if $frame; 494 | return $frame; 495 | } 496 | 497 | =head3 feed 498 | 499 | Feed decoder with chunks of server's response 500 | 501 | sysread $fh, $binary_data, 4096; 502 | $client->feed($binary_data); 503 | 504 | =cut 505 | 506 | sub feed { 507 | my ( $self, $chunk ) = @_; 508 | $self->{input} .= $chunk; 509 | my $offset = 0; 510 | my $len; 511 | my $con = $self->{con}; 512 | tracer->debug( "got " . length($chunk) . " bytes on a wire\n" ); 513 | if ( $con->upgrade ) { 514 | $len = $con->decode_upgrade_response( \$self->{input}, $offset ); 515 | $con->shutdown(1) unless defined $len; 516 | return unless $len; 517 | $offset += $len; 518 | $con->upgrade(0); 519 | $con->enqueue_raw( $con->preface_encode ); 520 | $con->preface(1); 521 | } 522 | while ( $len = $con->frame_decode( \$self->{input}, $offset ) ) { 523 | tracer->debug("decoded frame at $offset, length $len\n"); 524 | $offset += $len; 525 | } 526 | substr( $self->{input}, 0, $offset ) = '' if $offset; 527 | } 528 | 529 | =head3 ping 530 | 531 | Send ping frame to server (to keep connection alive) 532 | 533 | $client->ping 534 | 535 | or 536 | 537 | $client->ping($payload); 538 | 539 | Payload can be arbitrary binary string and must contain 8 octets. If payload argument 540 | is omitted client will send random data. 541 | 542 | =cut 543 | 544 | sub ping { 545 | shift->{con}->send_ping(@_); 546 | } 547 | 548 | 1; 549 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Connection.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Connection; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants 5 | qw(const_name :frame_types :errors :settings :flags :states 6 | :limits :endpoints); 7 | use Protocol::HTTP2::HeaderCompression qw(headers_encode); 8 | use Protocol::HTTP2::Frame; 9 | use Protocol::HTTP2::Stream; 10 | use Protocol::HTTP2::Upgrade; 11 | use Protocol::HTTP2::Trace qw(tracer); 12 | 13 | # Mixin 14 | our @ISA = 15 | qw(Protocol::HTTP2::Frame Protocol::HTTP2::Stream Protocol::HTTP2::Upgrade); 16 | 17 | # Default settings 18 | my %default_settings = ( 19 | &SETTINGS_HEADER_TABLE_SIZE => DEFAULT_HEADER_TABLE_SIZE, 20 | &SETTINGS_ENABLE_PUSH => DEFAULT_ENABLE_PUSH, 21 | &SETTINGS_MAX_CONCURRENT_STREAMS => DEFAULT_MAX_CONCURRENT_STREAMS, 22 | &SETTINGS_INITIAL_WINDOW_SIZE => DEFAULT_INITIAL_WINDOW_SIZE, 23 | &SETTINGS_MAX_FRAME_SIZE => DEFAULT_MAX_FRAME_SIZE, 24 | &SETTINGS_MAX_HEADER_LIST_SIZE => DEFAULT_MAX_HEADER_LIST_SIZE, 25 | ); 26 | 27 | sub new { 28 | my ( $class, $type, %opts ) = @_; 29 | my $self = bless { 30 | type => $type, 31 | 32 | streams => {}, 33 | 34 | last_stream => $type == CLIENT ? 1 : 2, 35 | last_peer_stream => 0, 36 | active_peer_streams => 0, 37 | 38 | encode_ctx => { 39 | 40 | # HPACK. Header Table 41 | header_table => [], 42 | 43 | # HPACK. Header Table size 44 | ht_size => 0, 45 | max_ht_size => DEFAULT_HEADER_TABLE_SIZE, 46 | 47 | settings => {%default_settings}, 48 | 49 | }, 50 | 51 | decode_ctx => { 52 | 53 | # HPACK. Header Table 54 | header_table => [], 55 | 56 | # HPACK. Header Table size 57 | ht_size => 0, 58 | max_ht_size => DEFAULT_HEADER_TABLE_SIZE, 59 | 60 | # HPACK. Emitted headers 61 | emitted_headers => [], 62 | 63 | # last frame 64 | frame => {}, 65 | 66 | settings => {%default_settings}, 67 | }, 68 | 69 | # Current error 70 | error => 0, 71 | 72 | # Output frames queue 73 | queue => [], 74 | 75 | # Connection must be shutdown 76 | shutdown => 0, 77 | 78 | # issued GOAWAY: no new streams on this connection 79 | goaway => 0, 80 | 81 | # get preface 82 | preface => 0, 83 | 84 | # perform upgrade 85 | upgrade => 0, 86 | 87 | # flow control 88 | fcw_send => DEFAULT_INITIAL_WINDOW_SIZE, 89 | fcw_recv => DEFAULT_INITIAL_WINDOW_SIZE, 90 | 91 | # stream where expected CONTINUATION frames 92 | pending_stream => undef, 93 | 94 | }, $class; 95 | 96 | for (qw(on_change_state on_new_peer_stream on_error upgrade)) { 97 | $self->{$_} = $opts{$_} if exists $opts{$_}; 98 | } 99 | 100 | if ( exists $opts{settings} ) { 101 | for ( keys %{ $opts{settings} } ) { 102 | $self->{decode_ctx}->{settings}->{$_} = $opts{settings}{$_}; 103 | } 104 | } 105 | 106 | # Sync decode context max_ht_size 107 | $self->{decode_ctx}->{max_ht_size} = 108 | $self->{decode_ctx}->{settings}->{&SETTINGS_HEADER_TABLE_SIZE}; 109 | 110 | $self; 111 | } 112 | 113 | sub decode_context { 114 | shift->{decode_ctx}; 115 | } 116 | 117 | sub encode_context { 118 | shift->{encode_ctx}; 119 | } 120 | 121 | sub pending_stream { 122 | shift->{pending_stream}; 123 | } 124 | 125 | sub dequeue { 126 | my $self = shift; 127 | shift @{ $self->{queue} }; 128 | } 129 | 130 | sub enqueue_raw { 131 | my $self = shift; 132 | push @{ $self->{queue} }, @_; 133 | } 134 | 135 | sub enqueue { 136 | my $self = shift; 137 | while ( my ( $type, $flags, $stream_id, $data_ref ) = splice( @_, 0, 4 ) ) { 138 | push @{ $self->{queue} }, 139 | $self->frame_encode( $type, $flags, $stream_id, $data_ref ); 140 | $self->state_machine( 'send', $type, $flags, $stream_id ); 141 | } 142 | } 143 | 144 | sub enqueue_first { 145 | my $self = shift; 146 | my $i = 0; 147 | for ( 0 .. $#{ $self->{queue} } ) { 148 | my $type = 149 | ( $self->frame_header_decode( \$self->{queue}->[$_], 0 ) )[1]; 150 | last if $type != CONTINUATION && $type != PING; 151 | $i++; 152 | } 153 | while ( my ( $type, $flags, $stream_id, $data_ref ) = splice( @_, 0, 4 ) ) { 154 | splice @{ $self->{queue} }, $i++, 0, 155 | $self->frame_encode( $type, $flags, $stream_id, $data_ref ); 156 | $self->state_machine( 'send', $type, $flags, $stream_id ); 157 | } 158 | } 159 | 160 | sub finish { 161 | my $self = shift; 162 | $self->enqueue( GOAWAY, 0, 0, 163 | [ $self->{last_peer_stream}, $self->{error} ] ) 164 | unless $self->shutdown; 165 | $self->shutdown(1); 166 | } 167 | 168 | sub shutdown { 169 | my $self = shift; 170 | $self->{shutdown} = shift if @_; 171 | $self->{shutdown}; 172 | } 173 | 174 | sub goaway { 175 | my $self = shift; 176 | $self->{goaway} = shift if @_; 177 | $self->{goaway}; 178 | } 179 | 180 | sub preface { 181 | my $self = shift; 182 | $self->{preface} = shift if @_; 183 | $self->{preface}; 184 | } 185 | 186 | sub upgrade { 187 | my $self = shift; 188 | $self->{upgrade} = shift if @_; 189 | $self->{upgrade}; 190 | } 191 | 192 | sub state_machine { 193 | my ( $self, $act, $type, $flags, $stream_id ) = @_; 194 | 195 | return 196 | if $stream_id == 0 197 | || $type == SETTINGS 198 | || $type == GOAWAY 199 | || $self->upgrade 200 | || !$self->preface; 201 | 202 | my $promised_sid = $self->stream_promised_sid($stream_id); 203 | 204 | my $prev_state = $self->{streams}->{ $promised_sid || $stream_id }->{state}; 205 | 206 | # REFUSED_STREAM error 207 | return if !defined $prev_state && $type == RST_STREAM && $act eq 'send'; 208 | 209 | # Direction server->client 210 | my $srv2cln = ( $self->{type} == SERVER && $act eq 'send' ) 211 | || ( $self->{type} == CLIENT && $act eq 'recv' ); 212 | 213 | # Direction client->server 214 | my $cln2srv = ( $self->{type} == SERVER && $act eq 'recv' ) 215 | || ( $self->{type} == CLIENT && $act eq 'send' ); 216 | 217 | # Do we expect CONTINUATION after this frame? 218 | my $pending = ( $type == HEADERS || $type == PUSH_PROMISE ) 219 | && !( $flags & END_HEADERS ); 220 | 221 | #tracer->debug( 222 | # sprintf "\e[0;31mStream state: frame %s is %s%s on %s stream %i\e[m\n", 223 | # const_name( "frame_types", $type ), 224 | # $act, 225 | # $pending ? "*" : "", 226 | # const_name( "states", $prev_state ), 227 | # $promised_sid || $stream_id, 228 | #); 229 | 230 | # Wait until all CONTINUATION frames arrive 231 | if ( my $ps = $self->stream_pending_state($stream_id) ) { 232 | if ( $type != CONTINUATION ) { 233 | tracer->error( 234 | sprintf "invalid frame type %s. Expected CONTINUATION frame\n", 235 | const_name( "frame_types", $type ) 236 | ); 237 | $self->error(PROTOCOL_ERROR); 238 | } 239 | elsif ( $flags & END_HEADERS ) { 240 | $self->stream_promised_sid( $stream_id, undef ) if $promised_sid; 241 | $self->stream_pending_state( $promised_sid || $stream_id, undef ); 242 | $self->stream_state( $promised_sid || $stream_id, $ps ); 243 | } 244 | } 245 | 246 | # Unexpected CONTINUATION frame 247 | elsif ( $type == CONTINUATION ) { 248 | tracer->error("Unexpected CONTINUATION frame\n"); 249 | $self->error(PROTOCOL_ERROR); 250 | } 251 | 252 | # State machine 253 | # IDLE 254 | elsif ( $prev_state == IDLE ) { 255 | if ( $type == HEADERS && $cln2srv ) { 256 | $self->stream_state( $stream_id, 257 | ( $flags & END_STREAM ) ? HALF_CLOSED : OPEN, $pending ); 258 | } 259 | elsif ( $type == PUSH_PROMISE && $srv2cln ) { 260 | $self->stream_state( $promised_sid, RESERVED, $pending ); 261 | $self->stream_promised_sid( $stream_id, undef ) 262 | if $flags & END_HEADERS; 263 | } 264 | 265 | # first frame in stream is invalid, so state is yet IDLE 266 | elsif ( $type == RST_STREAM && $act eq 'send' ) { 267 | tracer->notice('send RST_STREAM on IDLE state. possible bug?'); 268 | $self->stream_state( $stream_id, CLOSED ); 269 | } 270 | elsif ( $type != PRIORITY ) { 271 | tracer->error( 272 | sprintf "invalid frame type %s for current stream state %s\n", 273 | const_name( "frame_types", $type ), 274 | const_name( "states", $prev_state ) 275 | ); 276 | $self->error(PROTOCOL_ERROR); 277 | } 278 | } 279 | 280 | # OPEN 281 | elsif ( $prev_state == OPEN ) { 282 | if ( ( $flags & END_STREAM ) 283 | && ( $type == DATA || $type == HEADERS ) ) 284 | { 285 | $self->stream_state( $stream_id, HALF_CLOSED, $pending ); 286 | } 287 | elsif ( $type == RST_STREAM ) { 288 | $self->stream_state( $stream_id, CLOSED ); 289 | } 290 | elsif ($type == HEADERS 291 | && !$pending 292 | && $self->stream_trailer($stream_id) ) 293 | { 294 | tracer->error("expected END_STREAM flag for trailer HEADERS frame"); 295 | $self->error(PROTOCOL_ERROR); 296 | } 297 | } 298 | 299 | # RESERVED (local/remote) 300 | elsif ( $prev_state == RESERVED ) { 301 | if ( $type == RST_STREAM ) { 302 | $self->stream_state( $stream_id, CLOSED ); 303 | } 304 | elsif ( $type == HEADERS && $srv2cln ) { 305 | $self->stream_state( $stream_id, 306 | ( $flags & END_STREAM ) ? CLOSED : HALF_CLOSED, $pending ); 307 | } 308 | elsif ( $type != PRIORITY && $cln2srv ) { 309 | tracer->error("invalid frame $type for state RESERVED"); 310 | $self->error(PROTOCOL_ERROR); 311 | } 312 | } 313 | 314 | # HALF_CLOSED (local/remote) 315 | elsif ( $prev_state == HALF_CLOSED ) { 316 | if ( ( $type == RST_STREAM ) 317 | || ( ( $flags & END_STREAM ) && $srv2cln ) ) 318 | { 319 | $self->stream_state( $stream_id, CLOSED, $pending ); 320 | } 321 | elsif ( ( !grep { $type == $_ } ( WINDOW_UPDATE, PRIORITY ) ) 322 | && $cln2srv ) 323 | { 324 | tracer->error( sprintf "invalid frame %s for state HALF CLOSED\n", 325 | const_name( "frame_types", $type ) ); 326 | $self->error(PROTOCOL_ERROR); 327 | } 328 | } 329 | 330 | # CLOSED 331 | elsif ( $prev_state == CLOSED ) { 332 | if ( $type != PRIORITY && ( $type != WINDOW_UPDATE && $cln2srv ) ) { 333 | 334 | tracer->error("stream is closed\n"); 335 | $self->error(STREAM_CLOSED); 336 | } 337 | } 338 | else { 339 | tracer->error("oops!\n"); 340 | $self->error(INTERNAL_ERROR); 341 | } 342 | } 343 | 344 | # TODO: move this to some other module 345 | sub send_headers { 346 | my ( $self, $stream_id, $headers, $end ) = @_; 347 | my $max_size = $self->enc_setting(SETTINGS_MAX_FRAME_SIZE); 348 | 349 | my $header_block = headers_encode( $self->encode_context, $headers ); 350 | 351 | my $flags = $end ? END_STREAM : 0; 352 | $flags |= END_HEADERS if length($header_block) <= $max_size; 353 | 354 | $self->enqueue( HEADERS, $flags, $stream_id, 355 | { hblock => \substr( $header_block, 0, $max_size, '' ) } ); 356 | while ( length($header_block) > 0 ) { 357 | my $flags = length($header_block) <= $max_size ? 0 : END_HEADERS; 358 | $self->enqueue( CONTINUATION, $flags, 359 | $stream_id, \substr( $header_block, 0, $max_size, '' ) ); 360 | } 361 | } 362 | 363 | sub send_pp_headers { 364 | my ( $self, $stream_id, $promised_id, $headers ) = @_; 365 | my $max_size = $self->enc_setting(SETTINGS_MAX_FRAME_SIZE); 366 | 367 | my $header_block = headers_encode( $self->encode_context, $headers ); 368 | 369 | my $flags = length($header_block) <= $max_size ? END_HEADERS : 0; 370 | 371 | $self->enqueue( PUSH_PROMISE, $flags, $stream_id, 372 | [ $promised_id, \substr( $header_block, 0, $max_size - 4, '' ) ] ); 373 | 374 | while ( length($header_block) > 0 ) { 375 | my $flags = length($header_block) <= $max_size ? 0 : END_HEADERS; 376 | $self->enqueue( CONTINUATION, $flags, 377 | $stream_id, \substr( $header_block, 0, $max_size, '' ) ); 378 | } 379 | } 380 | 381 | sub send_data { 382 | my ( $self, $stream_id, $chunk, $end ) = @_; 383 | my $data = $self->stream_blocked_data($stream_id); 384 | $data .= defined $chunk ? $chunk : ''; 385 | $self->stream_end( $stream_id, $end ) if defined $end; 386 | $end = $self->stream_end($stream_id); 387 | 388 | while (1) { 389 | my $l = length($data); 390 | my $size = $self->enc_setting(SETTINGS_MAX_FRAME_SIZE); 391 | for ( $l, $self->fcw_send, $self->stream_fcw_send($stream_id) ) { 392 | $size = $_ if $size > $_; 393 | } 394 | 395 | # Flow control 396 | last if $l != 0 && $size <= 0; 397 | $self->fcw_send( -$size ); 398 | $self->stream_fcw_send( $stream_id, -$size ); 399 | 400 | $self->enqueue( 401 | DATA, $end && $l == $size ? END_STREAM : 0, 402 | $stream_id, \substr( $data, 0, $size, '' ) 403 | ); 404 | last if $l == $size; 405 | } 406 | $self->stream_blocked_data( $stream_id, $data ); 407 | } 408 | 409 | sub send_blocked { 410 | my $self = shift; 411 | for my $stream_id ( keys %{ $self->{streams} } ) { 412 | $self->stream_send_blocked($stream_id); 413 | } 414 | } 415 | 416 | sub error { 417 | my $self = shift; 418 | if ( @_ && !$self->{shutdown} ) { 419 | $self->{error} = shift; 420 | $self->{on_error}->( $self->{error} ) if exists $self->{on_error}; 421 | $self->finish; 422 | } 423 | $self->{error}; 424 | } 425 | 426 | sub setting { 427 | require Carp; 428 | Carp::confess("setting is deprecated\n"); 429 | } 430 | 431 | sub _setting { 432 | my ( $ctx, $self, $setting ) = @_; 433 | my $s = $self->{$ctx}->{settings}; 434 | return undef unless exists $s->{$setting}; 435 | $s->{$setting} = pop if @_ > 3; 436 | $s->{$setting}; 437 | } 438 | 439 | sub enc_setting { 440 | _setting( 'encode_ctx', @_ ); 441 | } 442 | 443 | sub dec_setting { 444 | _setting( 'decode_ctx', @_ ); 445 | } 446 | 447 | sub accept_settings { 448 | my $self = shift; 449 | $self->enqueue( SETTINGS, ACK, 0, {} ); 450 | } 451 | 452 | # Flow control windown of connection 453 | sub _fcw { 454 | my $dir = shift; 455 | my $self = shift; 456 | 457 | if (@_) { 458 | $self->{$dir} += shift; 459 | tracer->debug( "$dir now is " . $self->{$dir} . "\n" ); 460 | } 461 | $self->{$dir}; 462 | } 463 | 464 | sub fcw_send { 465 | _fcw( 'fcw_send', @_ ); 466 | } 467 | 468 | sub fcw_recv { 469 | _fcw( 'fcw_recv', @_ ); 470 | } 471 | 472 | sub fcw_update { 473 | my $self = shift; 474 | 475 | # TODO: check size of data in memory 476 | my $size = $self->dec_setting(SETTINGS_INITIAL_WINDOW_SIZE); 477 | tracer->debug("update fcw recv of connection with $size b.\n"); 478 | $self->fcw_recv($size); 479 | $self->enqueue( WINDOW_UPDATE, 0, 0, $size ); 480 | } 481 | 482 | sub fcw_initial_change { 483 | my ( $self, $size ) = @_; 484 | my $prev_size = $self->enc_setting(SETTINGS_INITIAL_WINDOW_SIZE); 485 | my $diff = $size - $prev_size; 486 | tracer->debug( 487 | "Change flow control window on not closed streams with diff $diff\n"); 488 | for my $stream_id ( keys %{ $self->{streams} } ) { 489 | next if $self->stream_state($stream_id) == CLOSED; 490 | $self->stream_fcw_send( $stream_id, $diff ); 491 | } 492 | } 493 | 494 | sub ack_ping { 495 | my ( $self, $payload_ref ) = @_; 496 | $self->enqueue_first( PING, ACK, 0, $payload_ref ); 497 | } 498 | 499 | sub send_ping { 500 | my ( $self, $payload ) = @_; 501 | if ( !defined $payload ) { 502 | $payload = pack "C*", map { rand(256) } 1 .. PING_PAYLOAD_SIZE; 503 | } 504 | elsif ( length($payload) != PING_PAYLOAD_SIZE ) { 505 | $payload = sprintf "%*.*s", 506 | -PING_PAYLOAD_SIZE(), PING_PAYLOAD_SIZE, $payload; 507 | } 508 | $self->enqueue( PING, 0, 0, \$payload ); 509 | } 510 | 511 | 1; 512 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Constants.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Constants; 2 | use strict; 3 | use warnings; 4 | use constant { 5 | 6 | # Header Compression 7 | MAX_INT_SIZE => 4, 8 | MAX_PAYLOAD_SIZE => ( 1 << 24 ) - 1, 9 | 10 | # Frame 11 | FRAME_HEADER_SIZE => 9, 12 | 13 | # Flow control 14 | MAX_FCW_SIZE => ( 1 << 31 ) - 1, 15 | 16 | # Ping payload 17 | PING_PAYLOAD_SIZE => 8, 18 | 19 | # Settings defaults 20 | DEFAULT_HEADER_TABLE_SIZE => 4_096, 21 | DEFAULT_ENABLE_PUSH => 1, 22 | DEFAULT_MAX_CONCURRENT_STREAMS => 100, 23 | DEFAULT_INITIAL_WINDOW_SIZE => 65_535, 24 | DEFAULT_MAX_FRAME_SIZE => 16_384, 25 | DEFAULT_MAX_HEADER_LIST_SIZE => 65_536, 26 | 27 | # Priority 28 | DEFAULT_WEIGHT => 16, 29 | 30 | # Stream states 31 | IDLE => 1, 32 | RESERVED => 2, 33 | OPEN => 3, 34 | HALF_CLOSED => 4, 35 | CLOSED => 5, 36 | 37 | # Endpoint types 38 | CLIENT => 1, 39 | SERVER => 2, 40 | 41 | # Preface string 42 | PREFACE => "PRI * HTTP/2.0\x0d\x0a\x0d\x0aSM\x0d\x0a\x0d\x0a", 43 | 44 | # Frame types 45 | DATA => 0, 46 | HEADERS => 1, 47 | PRIORITY => 2, 48 | RST_STREAM => 3, 49 | SETTINGS => 4, 50 | PUSH_PROMISE => 5, 51 | PING => 6, 52 | GOAWAY => 7, 53 | WINDOW_UPDATE => 8, 54 | CONTINUATION => 9, 55 | 56 | # Flags 57 | ACK => 0x1, 58 | END_STREAM => 0x1, 59 | END_HEADERS => 0x4, 60 | PADDED => 0x8, 61 | PRIORITY_FLAG => 0x20, 62 | 63 | # Errors 64 | NO_ERROR => 0, 65 | PROTOCOL_ERROR => 1, 66 | INTERNAL_ERROR => 2, 67 | FLOW_CONTROL_ERROR => 3, 68 | SETTINGS_TIMEOUT => 4, 69 | STREAM_CLOSED => 5, 70 | FRAME_SIZE_ERROR => 6, 71 | REFUSED_STREAM => 7, 72 | CANCEL => 8, 73 | COMPRESSION_ERROR => 9, 74 | CONNECT_ERROR => 10, 75 | ENHANCE_YOUR_CALM => 11, 76 | INADEQUATE_SECURITY => 12, 77 | HTTP_1_1_REQUIRED => 13, 78 | 79 | # SETTINGS 80 | SETTINGS_HEADER_TABLE_SIZE => 1, 81 | SETTINGS_ENABLE_PUSH => 2, 82 | SETTINGS_MAX_CONCURRENT_STREAMS => 3, 83 | SETTINGS_INITIAL_WINDOW_SIZE => 4, 84 | SETTINGS_MAX_FRAME_SIZE => 5, 85 | SETTINGS_MAX_HEADER_LIST_SIZE => 6, 86 | 87 | }; 88 | 89 | require Exporter; 90 | our @ISA = qw(Exporter); 91 | our %EXPORT_TAGS = ( 92 | frame_types => [ 93 | qw(DATA HEADERS PRIORITY RST_STREAM SETTINGS PUSH_PROMISE PING GOAWAY 94 | WINDOW_UPDATE CONTINUATION) 95 | ], 96 | errors => [ 97 | qw(NO_ERROR PROTOCOL_ERROR INTERNAL_ERROR FLOW_CONTROL_ERROR 98 | SETTINGS_TIMEOUT STREAM_CLOSED FRAME_SIZE_ERROR REFUSED_STREAM CANCEL 99 | COMPRESSION_ERROR CONNECT_ERROR ENHANCE_YOUR_CALM INADEQUATE_SECURITY 100 | HTTP_1_1_REQUIRED) 101 | ], 102 | preface => [qw(PREFACE)], 103 | flags => [qw(ACK END_STREAM END_HEADERS PADDED PRIORITY_FLAG)], 104 | settings => [ 105 | qw(SETTINGS_HEADER_TABLE_SIZE SETTINGS_ENABLE_PUSH 106 | SETTINGS_MAX_CONCURRENT_STREAMS SETTINGS_INITIAL_WINDOW_SIZE 107 | SETTINGS_MAX_FRAME_SIZE SETTINGS_MAX_HEADER_LIST_SIZE) 108 | ], 109 | limits => [ 110 | qw(MAX_INT_SIZE MAX_PAYLOAD_SIZE PING_PAYLOAD_SIZE MAX_FCW_SIZE 111 | DEFAULT_WEIGHT DEFAULT_HEADER_TABLE_SIZE DEFAULT_MAX_CONCURRENT_STREAMS 112 | DEFAULT_ENABLE_PUSH DEFAULT_INITIAL_WINDOW_SIZE DEFAULT_MAX_FRAME_SIZE 113 | DEFAULT_MAX_HEADER_LIST_SIZE FRAME_HEADER_SIZE) 114 | ], 115 | states => [qw(IDLE RESERVED OPEN HALF_CLOSED CLOSED)], 116 | endpoints => [qw(CLIENT SERVER)], 117 | ); 118 | 119 | my %reverse; 120 | { 121 | no strict 'refs'; 122 | for my $k ( keys %EXPORT_TAGS ) { 123 | for my $v ( @{ $EXPORT_TAGS{$k} } ) { 124 | $reverse{$k}{ &{$v} } = $v; 125 | } 126 | } 127 | } 128 | 129 | sub const_name { 130 | my ( $tag, $value ) = @_; 131 | exists $reverse{$tag} ? ( $reverse{$tag}{$value} || '' ) : ''; 132 | } 133 | 134 | our @EXPORT_OK = ( qw(const_name), map { @$_ } values %EXPORT_TAGS ); 135 | 136 | 1; 137 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Frame.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Frame; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Trace qw(tracer); 5 | use Protocol::HTTP2::Constants 6 | qw(const_name :frame_types :errors :preface :states :flags :limits :settings); 7 | use Protocol::HTTP2::Frame::Data; 8 | use Protocol::HTTP2::Frame::Headers; 9 | use Protocol::HTTP2::Frame::Priority; 10 | use Protocol::HTTP2::Frame::Rst_stream; 11 | use Protocol::HTTP2::Frame::Settings; 12 | use Protocol::HTTP2::Frame::Push_promise; 13 | use Protocol::HTTP2::Frame::Ping; 14 | use Protocol::HTTP2::Frame::Goaway; 15 | use Protocol::HTTP2::Frame::Window_update; 16 | use Protocol::HTTP2::Frame::Continuation; 17 | 18 | # Table of payload decoders 19 | my %frame_class = ( 20 | &DATA => 'Data', 21 | &HEADERS => 'Headers', 22 | &PRIORITY => 'Priority', 23 | &RST_STREAM => 'Rst_stream', 24 | &SETTINGS => 'Settings', 25 | &PUSH_PROMISE => 'Push_promise', 26 | &PING => 'Ping', 27 | &GOAWAY => 'Goaway', 28 | &WINDOW_UPDATE => 'Window_update', 29 | &CONTINUATION => 'Continuation', 30 | ); 31 | 32 | my %decoder = 33 | map { $_ => \&{ 'Protocol::HTTP2::Frame::' . $frame_class{$_} . '::decode' } } 34 | keys %frame_class; 35 | 36 | my %encoder = 37 | map { $_ => \&{ 'Protocol::HTTP2::Frame::' . $frame_class{$_} . '::encode' } } 38 | keys %frame_class; 39 | 40 | sub frame_encode { 41 | my ( $con, $type, $flags, $stream_id, $data_ref ) = @_; 42 | 43 | my $payload = $encoder{$type}->( $con, \$flags, $stream_id, $data_ref ); 44 | my $l = length $payload; 45 | 46 | pack( 'CnC2N', ( $l >> 16 ), ( $l & 0xFFFF ), $type, $flags, $stream_id ) 47 | . $payload; 48 | } 49 | 50 | sub preface_decode { 51 | my ( $con, $buf_ref, $buf_offset ) = @_; 52 | return 0 if length($$buf_ref) - $buf_offset < length(PREFACE); 53 | return 54 | index( $$buf_ref, PREFACE, $buf_offset ) == -1 ? undef : length(PREFACE); 55 | } 56 | 57 | sub preface_encode { 58 | PREFACE; 59 | } 60 | 61 | sub frame_header_decode { 62 | my ( undef, $buf_ref, $buf_offset ) = @_; 63 | 64 | my ( $hl, $ll, $type, $flags, $stream_id ) = 65 | unpack( 'CnC2N', substr( $$buf_ref, $buf_offset, FRAME_HEADER_SIZE ) ); 66 | 67 | my $length = ( $hl << 16 ) + $ll; 68 | $stream_id &= 0x7FFF_FFFF; 69 | return $length, $type, $flags, $stream_id; 70 | } 71 | 72 | sub frame_decode { 73 | my ( $con, $buf_ref, $buf_offset ) = @_; 74 | return 0 if length($$buf_ref) - $buf_offset < FRAME_HEADER_SIZE; 75 | 76 | my ( $length, $type, $flags, $stream_id ) = 77 | $con->frame_header_decode( $buf_ref, $buf_offset ); 78 | 79 | if ( $length > $con->dec_setting(SETTINGS_MAX_FRAME_SIZE) ) { 80 | tracer->error("Frame is too large: $length\n"); 81 | $con->error(FRAME_SIZE_ERROR); 82 | return undef; 83 | } 84 | 85 | return 0 86 | if length($$buf_ref) - $buf_offset - FRAME_HEADER_SIZE - $length < 0; 87 | 88 | tracer->debug( 89 | sprintf "TYPE = %s(%i), FLAGS = %08b, STREAM_ID = %i, " 90 | . "LENGTH = %i\n", 91 | exists $frame_class{$type} 92 | ? const_name( "frame_types", $type ) 93 | : "UNKNOWN", 94 | $type, 95 | $flags, 96 | $stream_id, 97 | $length 98 | ); 99 | 100 | my $pending_stream_id = $con->pending_stream; 101 | if ( $pending_stream_id 102 | && ( $type != CONTINUATION || $pending_stream_id != $stream_id ) ) 103 | { 104 | tracer->debug("Expected CONTINUATION for stream $pending_stream_id"); 105 | $con->error(PROTOCOL_ERROR); 106 | return undef; 107 | } 108 | 109 | # Unknown type of frame 110 | if ( !exists $frame_class{$type} ) { 111 | tracer->info("ignore unknown frame type $type"); 112 | return FRAME_HEADER_SIZE + $length; 113 | } 114 | 115 | $con->decode_context->{frame} = { 116 | type => $type, 117 | flags => $flags, 118 | length => $length, 119 | stream => $stream_id, 120 | }; 121 | 122 | # Try to create new stream structure 123 | if ( $stream_id 124 | && !$con->stream($stream_id) 125 | && !$con->new_peer_stream($stream_id) ) 126 | { 127 | return $con->error ? undef : FRAME_HEADER_SIZE + $length; 128 | } 129 | 130 | return undef 131 | unless defined $decoder{$type} 132 | ->( $con, $buf_ref, $buf_offset + FRAME_HEADER_SIZE, $length ); 133 | 134 | # Arrived frame may change state of stream 135 | $con->state_machine( 'recv', $type, $flags, $stream_id ); 136 | 137 | return FRAME_HEADER_SIZE + $length; 138 | } 139 | 140 | =pod 141 | 142 | =head1 NOTES 143 | 144 | =head2 Frame Types vs Flags and Stream ID 145 | 146 | Table represent possible combination of frame types and flags. 147 | Last column -- Stream ID of frame types (x -- sid >= 1, 0 -- sid = 0) 148 | 149 | 150 | +-END_STREAM 0x1 151 | | +-ACK 0x1 152 | | | +-END_HEADERS 0x4 153 | | | | +-PADDED 0x8 154 | | | | | +-PRIORITY 0x20 155 | | | | | | +-stream id (value) 156 | | | | | | | 157 | | frame type\flag | V | V | V | V | V | | V | 158 | | --------------- |:-:|:-:|:-:|:-:|:-:| - |:---:| 159 | | DATA | x | | | x | | | x | 160 | | HEADERS | x | | x | x | x | | x | 161 | | PRIORITY | | | | | | | x | 162 | | RST_STREAM | | | | | | | x | 163 | | SETTINGS | | x | | | | | 0 | 164 | | PUSH_PROMISE | | | x | x | | | x | 165 | | PING | | x | | | | | 0 | 166 | | GOAWAY | | | | | | | 0 | 167 | | WINDOW_UPDATE | | | | | | | 0/x | 168 | | CONTINUATION | | | x | x | | | x | 169 | 170 | =cut 171 | 172 | 1; 173 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Frame/Continuation.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Frame::Continuation; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants qw(:flags :errors); 5 | use Protocol::HTTP2::Trace qw(tracer); 6 | 7 | sub decode { 8 | my ( $con, $buf_ref, $buf_offset, $length ) = @_; 9 | my $frame_ref = $con->decode_context->{frame}; 10 | 11 | # Protocol errors 12 | if ( 13 | # CONTINUATION frames MUST be associated with a stream 14 | $frame_ref->{stream} == 0 15 | ) 16 | { 17 | $con->error(PROTOCOL_ERROR); 18 | return undef; 19 | } 20 | 21 | $con->stream_header_block( $frame_ref->{stream}, 22 | substr( $$buf_ref, $buf_offset, $length ) ); 23 | 24 | # Stream header block complete 25 | $con->stream_headers_done( $frame_ref->{stream} ) 26 | or return undef 27 | if $frame_ref->{flags} & END_HEADERS; 28 | 29 | return $length; 30 | 31 | } 32 | 33 | sub encode { 34 | my ( $con, $flags_ref, $stream, $data_ref ) = @_; 35 | return $$data_ref; 36 | } 37 | 38 | 1; 39 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Frame/Data.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Frame::Data; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants qw(:flags :errors :settings :limits); 5 | use Protocol::HTTP2::Trace qw(tracer); 6 | 7 | sub decode { 8 | my ( $con, $buf_ref, $buf_offset, $length ) = @_; 9 | my ( $pad, $offset ) = ( 0, 0 ); 10 | my $frame_ref = $con->decode_context->{frame}; 11 | 12 | # Protocol errors 13 | if ( 14 | # DATA frames MUST be associated with a stream 15 | $frame_ref->{stream} == 0 16 | ) 17 | { 18 | $con->error(PROTOCOL_ERROR); 19 | return undef; 20 | } 21 | 22 | if ( $frame_ref->{flags} & PADDED ) { 23 | $pad = unpack( 'C', substr( $$buf_ref, $buf_offset ) ); 24 | $offset += 1; 25 | } 26 | 27 | my $dblock_size = $length - $offset - $pad; 28 | if ( $dblock_size < 0 ) { 29 | tracer->error("Not enough space for data block\n"); 30 | $con->error(PROTOCOL_ERROR); 31 | return undef; 32 | } 33 | 34 | my $fcw = $con->fcw_recv( -$length ); 35 | my $stream_fcw = $con->stream_fcw_recv( $frame_ref->{stream}, -$length ); 36 | if ( $fcw < 0 || $stream_fcw < 0 ) { 37 | tracer->warning( 38 | "received data overflow flow control window: $fcw|$stream_fcw\n"); 39 | $con->stream_error( $frame_ref->{stream}, FLOW_CONTROL_ERROR ); 40 | return $length; 41 | } 42 | $con->fcw_update() if $fcw < $con->dec_setting(SETTINGS_MAX_FRAME_SIZE); 43 | $con->stream_fcw_update( $frame_ref->{stream} ) 44 | if $stream_fcw < $con->dec_setting(SETTINGS_MAX_FRAME_SIZE) 45 | && !( $frame_ref->{flags} & END_STREAM ); 46 | 47 | return $length unless $dblock_size; 48 | 49 | my $data = substr $$buf_ref, $buf_offset + $offset, $dblock_size; 50 | 51 | # Update stream data container 52 | $con->stream_data( $frame_ref->{stream}, $data ); 53 | 54 | # Check length of data matched content-length in header 55 | if ( $frame_ref->{flags} & END_STREAM ) { 56 | my $slen = $con->stream_length( $frame_ref->{stream} ); 57 | if ( defined $slen && defined $con->stream_data( $frame_ref->{stream} ) 58 | && $slen != length $con->stream_data( $frame_ref->{stream} ) ) 59 | { 60 | tracer->warning( 61 | "content-length header don't match data frames size\n"); 62 | $con->stream_error( $frame_ref->{stream}, PROTOCOL_ERROR ); 63 | } 64 | } 65 | 66 | return $length; 67 | } 68 | 69 | sub encode { 70 | my ( $con, $flags_ref, $stream_id, $data_ref ) = @_; 71 | 72 | return $$data_ref; 73 | } 74 | 75 | 1; 76 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Frame/Goaway.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Frame::Goaway; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants qw(const_name :flags :errors); 5 | use Protocol::HTTP2::Trace qw(tracer bin2hex); 6 | 7 | sub decode { 8 | my ( $con, $buf_ref, $buf_offset, $length ) = @_; 9 | my $frame_ref = $con->decode_context->{frame}; 10 | 11 | if ( $frame_ref->{stream} != 0 ) { 12 | $con->error(PROTOCOL_ERROR); 13 | return undef; 14 | } 15 | 16 | my ( $last_stream_id, $error_code ) = 17 | unpack( 'N2', substr( $$buf_ref, $buf_offset, 8 ) ); 18 | 19 | $last_stream_id &= 0x7FFF_FFFF; 20 | 21 | tracer->debug( "GOAWAY with error code " 22 | . const_name( 'errors', $error_code ) 23 | . " last stream is $last_stream_id\n" ); 24 | 25 | tracer->debug( "additional debug data: " 26 | . bin2hex( substr( $$buf_ref, $buf_offset + 8 ) ) 27 | . "\n" ) 28 | if $length - 8 > 0; 29 | 30 | $con->goaway(1); 31 | 32 | return $length; 33 | } 34 | 35 | sub encode { 36 | my ( $con, $flags_ref, $stream, $data ) = @_; 37 | 38 | $con->goaway(1); 39 | 40 | my $payload = pack( 'N2', @$data ); 41 | tracer->debug( "\tGOAWAY: last stream = $data->[0], error = " 42 | . const_name( "errors", $data->[1] ) 43 | . "\n" ); 44 | $payload .= $data->[2] if @$data > 2; 45 | return $payload; 46 | } 47 | 48 | 1; 49 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Frame/Headers.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Frame::Headers; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants qw(:flags :errors :states :limits); 5 | use Protocol::HTTP2::Trace qw(tracer); 6 | 7 | # 6.2 HEADERS 8 | sub decode { 9 | my ( $con, $buf_ref, $buf_offset, $length ) = @_; 10 | my ( $pad, $offset, $weight, $exclusive, $stream_dep ) = ( 0, 0 ); 11 | my $frame_ref = $con->decode_context->{frame}; 12 | 13 | # Protocol errors 14 | if ( 15 | # HEADERS frames MUST be associated with a stream 16 | $frame_ref->{stream} == 0 17 | ) 18 | { 19 | $con->error(PROTOCOL_ERROR); 20 | return undef; 21 | } 22 | 23 | if ( $frame_ref->{flags} & PADDED ) { 24 | $pad = unpack( 'C', substr( $$buf_ref, $buf_offset, 1 ) ); 25 | $offset += 1; 26 | } 27 | 28 | if ( $frame_ref->{flags} & PRIORITY_FLAG ) { 29 | ( $stream_dep, $weight ) = 30 | unpack( 'NC', substr( $$buf_ref, $buf_offset + $offset, 5 ) ); 31 | $exclusive = $stream_dep >> 31; 32 | $stream_dep &= 0x7FFF_FFFF; 33 | $weight++; 34 | 35 | $con->stream_weight( $frame_ref->{stream}, $weight ); 36 | unless ( 37 | $con->stream_reprio( 38 | $frame_ref->{stream}, $exclusive, $stream_dep 39 | ) 40 | ) 41 | { 42 | tracer->error("Malformed HEADERS frame priority"); 43 | $con->error(PROTOCOL_ERROR); 44 | return undef; 45 | } 46 | 47 | $offset += 5; 48 | } 49 | 50 | # Not enough space for header block 51 | my $hblock_size = $length - $offset - $pad; 52 | if ( $hblock_size < 0 ) { 53 | $con->error(PROTOCOL_ERROR); 54 | return undef; 55 | } 56 | 57 | $con->stream_header_block( $frame_ref->{stream}, 58 | substr( $$buf_ref, $buf_offset + $offset, $hblock_size ) ); 59 | 60 | # Stream header block complete 61 | $con->stream_headers_done( $frame_ref->{stream} ) 62 | or return undef 63 | if $frame_ref->{flags} & END_HEADERS; 64 | 65 | return $length; 66 | } 67 | 68 | sub encode { 69 | my ( $con, $flags_ref, $stream, $data_ref ) = @_; 70 | my $res = ''; 71 | 72 | if ( exists $data_ref->{padding} ) { 73 | $$flags_ref |= PADDED; 74 | $res .= pack 'C', $data_ref->{padding}; 75 | } 76 | 77 | if ( exists $data_ref->{stream_dep} || exists $data_ref->{weight} ) { 78 | $$flags_ref |= PRIORITY_FLAG; 79 | my $weight = ( $data_ref->{weight} || DEFAULT_WEIGHT ) - 1; 80 | my $stream_dep = $data_ref->{stream_dep} || 0; 81 | $stream_dep |= ( 1 << 31 ) if $data_ref->{exclusive}; 82 | $res .= pack 'NC', $stream_dep, $weight; 83 | } 84 | 85 | return $res . ${ $data_ref->{hblock} }; 86 | } 87 | 88 | 1; 89 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Frame/Ping.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Frame::Ping; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants qw(:flags :errors :limits); 5 | use Protocol::HTTP2::Trace qw(tracer); 6 | 7 | sub decode { 8 | my ( $con, $buf_ref, $buf_offset, $length ) = @_; 9 | my $frame_ref = $con->decode_context->{frame}; 10 | 11 | # PING associated with connection 12 | if ( $frame_ref->{stream} != 0 ) { 13 | $con->error(PROTOCOL_ERROR); 14 | return undef; 15 | } 16 | 17 | # payload is 8 octets 18 | if ( $length != PING_PAYLOAD_SIZE ) { 19 | $con->error(FRAME_SIZE_ERROR); 20 | return undef; 21 | } 22 | 23 | $con->ack_ping( \substr $$buf_ref, $buf_offset, $length ) 24 | unless $frame_ref->{flags} & ACK; 25 | 26 | return $length; 27 | } 28 | 29 | sub encode { 30 | my ( $con, $flags_ref, $stream, $data_ref ) = @_; 31 | if ( length($$data_ref) != PING_PAYLOAD_SIZE ) { 32 | $con->error(INTERNAL_ERROR); 33 | return undef; 34 | } 35 | return $$data_ref; 36 | } 37 | 38 | 1; 39 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Frame/Priority.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Frame::Priority; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants qw(:flags :errors); 5 | use Protocol::HTTP2::Trace qw(tracer); 6 | 7 | sub decode { 8 | my ( $con, $buf_ref, $buf_offset, $length ) = @_; 9 | my $frame_ref = $con->decode_context->{frame}; 10 | 11 | # Priority frames MUST be associated with a stream 12 | if ( $frame_ref->{stream} == 0 ) { 13 | $con->error(PROTOCOL_ERROR); 14 | return undef; 15 | } 16 | 17 | if ( $length != 5 ) { 18 | $con->error(FRAME_SIZE_ERROR); 19 | return undef; 20 | } 21 | 22 | my ( $stream_dep, $weight ) = 23 | unpack( 'NC', substr( $$buf_ref, $buf_offset, 5 ) ); 24 | my $exclusive = $stream_dep >> 31; 25 | $stream_dep &= 0x7FFF_FFFF; 26 | $weight++; 27 | 28 | $con->stream_weight( $frame_ref->{stream}, $weight ); 29 | unless ( 30 | $con->stream_reprio( $frame_ref->{stream}, $exclusive, $stream_dep ) ) 31 | { 32 | tracer->error("Malformed priority frame"); 33 | $con->error(PROTOCOL_ERROR); 34 | return undef; 35 | } 36 | 37 | return $length; 38 | } 39 | 40 | sub encode { 41 | my ( $con, $flags_ref, $stream, $data_ref ) = @_; 42 | my $stream_dep = $data_ref->[0]; 43 | my $weight = $data_ref->[1] - 1; 44 | pack( 'NC', $stream_dep, $weight ); 45 | } 46 | 47 | 1; 48 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Frame/Push_promise.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Frame::Push_promise; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants qw(:flags :errors :settings); 5 | use Protocol::HTTP2::Trace qw(tracer); 6 | 7 | sub decode { 8 | my ( $con, $buf_ref, $buf_offset, $length ) = @_; 9 | my ( $pad, $offset ) = ( 0, 0 ); 10 | my $frame_ref = $con->decode_context->{frame}; 11 | 12 | # Protocol errors 13 | if ( 14 | # PP frames MUST be associated with a stream 15 | $frame_ref->{stream} == 0 16 | 17 | # PP frames MUST be allowed 18 | || !$con->dec_setting(SETTINGS_ENABLE_PUSH) 19 | ) 20 | { 21 | $con->error(PROTOCOL_ERROR); 22 | return undef; 23 | } 24 | 25 | if ( $frame_ref->{flags} & PADDED ) { 26 | $pad = unpack( 'C', substr( $$buf_ref, $buf_offset ) ); 27 | $offset += 1; 28 | } 29 | 30 | my $promised_sid = unpack 'N', substr $$buf_ref, $buf_offset + $offset, 4; 31 | $promised_sid &= 0x7FFF_FFFF; 32 | $offset += 4; 33 | 34 | my $hblock_size = $length - $offset - $pad; 35 | if ( $hblock_size < 0 ) { 36 | tracer->error("Not enough space for header block\n"); 37 | $con->error(FRAME_SIZE_ERROR); 38 | return undef; 39 | } 40 | 41 | $con->new_peer_stream($promised_sid) or return undef; 42 | $con->stream_promised_sid( $frame_ref->{stream}, $promised_sid ); 43 | 44 | $con->stream_header_block( $frame_ref->{stream}, 45 | substr( $$buf_ref, $buf_offset + $offset, $hblock_size ) ); 46 | 47 | # PP header block complete 48 | $con->stream_headers_done( $frame_ref->{stream} ) 49 | or return undef 50 | if $frame_ref->{flags} & END_HEADERS; 51 | 52 | return $length; 53 | 54 | } 55 | 56 | sub encode { 57 | my ( $con, $flags_ref, $stream_id, $data_ref ) = @_; 58 | my $promised_id = $data_ref->[0]; 59 | my $hblock_ref = $data_ref->[1]; 60 | 61 | return pack( 'N', $promised_id ) . $$hblock_ref; 62 | } 63 | 64 | 1; 65 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Frame/Rst_stream.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Frame::Rst_stream; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants qw(const_name :flags :errors); 5 | use Protocol::HTTP2::Trace qw(tracer); 6 | 7 | sub decode { 8 | my ( $con, $buf_ref, $buf_offset, $length ) = @_; 9 | my $frame_ref = $con->decode_context->{frame}; 10 | 11 | # RST_STREAM associated with stream 12 | if ( $frame_ref->{stream} == 0 ) { 13 | tracer->error("Received reset stream with stream id 0"); 14 | $con->error(PROTOCOL_ERROR); 15 | return undef; 16 | } 17 | 18 | if ( $length != 4 ) { 19 | tracer->error("Received reset stream with invalid length $length"); 20 | $con->error(FRAME_SIZE_ERROR); 21 | return undef; 22 | } 23 | 24 | my $code = unpack( 'N', substr( $$buf_ref, $buf_offset, 4 ) ); 25 | 26 | tracer->debug( "Receive reset stream with error code " 27 | . const_name( "errors", $code ) 28 | . "\n" ); 29 | $con->stream_reset( $frame_ref->{stream}, $code ); 30 | 31 | return $length; 32 | } 33 | 34 | sub encode { 35 | my ( $con, $flags_ref, $stream, $data ) = @_; 36 | $con->stream_reset( $stream, $data ); 37 | return pack 'N', $data; 38 | } 39 | 40 | 1; 41 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Frame/Settings.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Frame::Settings; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants qw(const_name :flags :errors :limits :settings); 5 | use Protocol::HTTP2::Trace qw(tracer); 6 | 7 | my %s_check = ( 8 | &SETTINGS_MAX_FRAME_SIZE => { 9 | validator => sub { 10 | $_[0] <= MAX_PAYLOAD_SIZE && $_[0] >= DEFAULT_MAX_FRAME_SIZE; 11 | }, 12 | error => PROTOCOL_ERROR 13 | }, 14 | &SETTINGS_ENABLE_PUSH => { 15 | validator => sub { 16 | $_[0] == 0 || $_[0] == 1; 17 | }, 18 | error => PROTOCOL_ERROR 19 | }, 20 | &SETTINGS_INITIAL_WINDOW_SIZE => { 21 | validator => sub { 22 | $_[0] <= MAX_FCW_SIZE; 23 | }, 24 | error => FLOW_CONTROL_ERROR 25 | }, 26 | ); 27 | 28 | my %s_action = ( 29 | &SETTINGS_INITIAL_WINDOW_SIZE => sub { 30 | my ( $con, $size ) = @_; 31 | $con->fcw_initial_change($size); 32 | } 33 | ); 34 | 35 | sub decode { 36 | my ( $con, $buf_ref, $buf_offset, $length ) = @_; 37 | my $frame_ref = $con->decode_context->{frame}; 38 | 39 | if ( $frame_ref->{stream} != 0 ) { 40 | $con->error(PROTOCOL_ERROR); 41 | return undef; 42 | } 43 | 44 | # just ack for our previous settings 45 | if ( $frame_ref->{flags} & ACK ) { 46 | if ( $length != 0 ) { 47 | tracer->error( 48 | "ACK settings frame have non-zero ($length) payload\n"); 49 | $con->error(FRAME_SIZE_ERROR); 50 | return undef; 51 | } 52 | return 0 53 | 54 | # received empty settings (default), accept it 55 | } 56 | elsif ( $length == 0 ) { 57 | $con->accept_settings(); 58 | return 0; 59 | } 60 | 61 | if ( $length % 6 != 0 ) { 62 | tracer->error("Settings frame payload is broken (length $length)\n"); 63 | $con->error(FRAME_SIZE_ERROR); 64 | return undef; 65 | } 66 | 67 | my @settings = unpack( '(nN)*', substr( $$buf_ref, $buf_offset, $length ) ); 68 | while ( my ( $key, $value ) = splice @settings, 0, 2 ) { 69 | if ( !defined $con->enc_setting($key) ) { 70 | tracer->debug("\tUnknown setting $key\n"); 71 | 72 | # ignore unknown setting 73 | next; 74 | } 75 | elsif ( exists $s_check{$key} 76 | && !$s_check{$key}{validator}->($value) ) 77 | { 78 | tracer->debug( "\tInvalid value of setting " 79 | . const_name( "settings", $key ) . ": " 80 | . $value ); 81 | $con->error( $s_check{$key}{error} ); 82 | return undef; 83 | } 84 | 85 | # Settings change may run some action 86 | $s_action{$key}->( $con, $value ) if exists $s_action{$key}; 87 | 88 | tracer->debug( 89 | "\tSettings " . const_name( "settings", $key ) . " = $value\n" ); 90 | $con->enc_setting( $key, $value ); 91 | } 92 | 93 | $con->accept_settings(); 94 | return $length; 95 | } 96 | 97 | sub encode { 98 | my ( $con, $flags_ref, $stream, $data ) = @_; 99 | my $payload = ''; 100 | for my $key ( sort keys %$data ) { 101 | tracer->debug( "\tSettings " 102 | . const_name( "settings", $key ) 103 | . " = $data->{$key}\n" ); 104 | $payload .= pack( 'nN', $key, $data->{$key} ); 105 | } 106 | return $payload; 107 | } 108 | 109 | 1; 110 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Frame/Window_update.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Frame::Window_update; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants qw(:flags :errors :limits); 5 | use Protocol::HTTP2::Trace qw(tracer); 6 | 7 | sub decode { 8 | my ( $con, $buf_ref, $buf_offset, $length ) = @_; 9 | my $frame_ref = $con->decode_context->{frame}; 10 | 11 | if ( $length != 4 ) { 12 | tracer->error( 13 | "Received windows_update frame with invalid length $length"); 14 | $con->error(FRAME_SIZE_ERROR); 15 | return undef; 16 | } 17 | 18 | my $fcw_add = unpack 'N', substr $$buf_ref, $buf_offset, 4; 19 | $fcw_add &= 0x7FFF_FFFF; 20 | 21 | if ( $fcw_add == 0 ) { 22 | tracer->error("Received flow-control window increment of 0"); 23 | $con->error(PROTOCOL_ERROR); 24 | return undef; 25 | } 26 | 27 | if ( $frame_ref->{stream} == 0 ) { 28 | if ( $con->fcw_send($fcw_add) > MAX_FCW_SIZE ) { 29 | $con->error(FLOW_CONTROL_ERROR); 30 | } 31 | else { 32 | $con->send_blocked(); 33 | } 34 | } 35 | else { 36 | my $fcw = $con->stream_fcw_send( $frame_ref->{stream}, $fcw_add ); 37 | if ( defined $fcw && $fcw > MAX_FCW_SIZE ) { 38 | tracer->warning("flow-control window size exceeded MAX_FCW_SIZE"); 39 | $con->stream_error( $frame_ref->{stream}, FLOW_CONTROL_ERROR ); 40 | } 41 | elsif ( defined $fcw ) { 42 | $con->stream_send_blocked( $frame_ref->{stream} ); 43 | } 44 | } 45 | return $length; 46 | } 47 | 48 | sub encode { 49 | my ( $con, $flags_ref, $stream, $data ) = @_; 50 | return pack 'N', $data; 51 | } 52 | 53 | 1; 54 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/HeaderCompression.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::HeaderCompression; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Huffman; 5 | use Protocol::HTTP2::StaticTable; 6 | use Protocol::HTTP2::Constants qw(:errors :settings :limits); 7 | use Protocol::HTTP2::Trace qw(tracer bin2hex); 8 | use Exporter qw(import); 9 | our @EXPORT_OK = qw(int_encode int_decode str_encode str_decode headers_decode 10 | headers_encode); 11 | 12 | sub int_encode { 13 | my ( $int, $N ) = @_; 14 | $N ||= 7; 15 | my $ff = ( 1 << $N ) - 1; 16 | 17 | if ( $int < $ff ) { 18 | return pack 'C', $int; 19 | } 20 | 21 | my $res = pack 'C', $ff; 22 | $int -= $ff; 23 | 24 | while ( $int >= 0x80 ) { 25 | $res .= pack( 'C', ( $int & 0x7f ) | 0x80 ); 26 | $int >>= 7; 27 | } 28 | 29 | return $res . pack( 'C', $int ); 30 | } 31 | 32 | # int_decode() 33 | # 34 | # arguments: 35 | # buf_ref - ref to buffer with encoded data 36 | # buf_offset - offset in buffer 37 | # int_ref - ref to scalar where result will be stored 38 | # N - bits in first byte 39 | # 40 | # returns: count of read bytes of encoded integer 41 | # or undef on error (malformed data) 42 | 43 | sub int_decode { 44 | my ( $buf_ref, $buf_offset, $int_ref, $N ) = @_; 45 | return undef if length($$buf_ref) - $buf_offset <= 0; 46 | $N ||= 7; 47 | my $ff = ( 1 << $N ) - 1; 48 | 49 | $$int_ref = $ff & vec( $$buf_ref, $buf_offset, 8 ); 50 | return 1 if $$int_ref < $ff; 51 | 52 | my $l = length($$buf_ref) - $buf_offset - 1; 53 | 54 | for my $i ( 1 .. $l ) { 55 | return undef if $i > MAX_INT_SIZE; 56 | my $s = vec( $$buf_ref, $i + $buf_offset, 8 ); 57 | $$int_ref += ( $s & 0x7f ) << ( $i - 1 ) * 7; 58 | return $i + 1 if $s < 0x80; 59 | } 60 | 61 | return undef; 62 | } 63 | 64 | sub str_encode { 65 | my $str = shift; 66 | my $huff_str = huffman_encode($str); 67 | my $pack; 68 | if ( length($huff_str) < length($str) ) { 69 | $pack = int_encode( length($huff_str), 7 ); 70 | vec( $pack, 7, 1 ) = 1; 71 | $pack .= $huff_str; 72 | } 73 | else { 74 | $pack = int_encode( length($str), 7 ); 75 | $pack .= $str; 76 | } 77 | return $pack; 78 | } 79 | 80 | # str_decode() 81 | # arguments: 82 | # buf_ref - ref to buffer with encoded data 83 | # buf_offset - offset in buffer 84 | # str_ref - ref to scalar where result will be stored 85 | # returns: count of read bytes of encoded data 86 | 87 | sub str_decode { 88 | my ( $buf_ref, $buf_offset, $str_ref ) = @_; 89 | my $offset = int_decode( $buf_ref, $buf_offset, \my $l, 7 ); 90 | return undef 91 | unless defined $offset 92 | && length($$buf_ref) - $buf_offset - $offset >= $l; 93 | 94 | $$str_ref = substr $$buf_ref, $offset + $buf_offset, $l; 95 | $$str_ref = huffman_decode($$str_ref) 96 | if vec( $$buf_ref, $buf_offset * 8 + 7, 1 ) == 1; 97 | return $offset + $l; 98 | } 99 | 100 | sub evict_ht { 101 | my ( $context, $size ) = @_; 102 | my @evicted; 103 | 104 | my $ht = $context->{header_table}; 105 | 106 | while ( $context->{ht_size} + $size > $context->{max_ht_size} ) { 107 | my $n = $#$ht; 108 | my $kv_ref = pop @$ht; 109 | $context->{ht_size} -= 110 | 32 + length( $kv_ref->[0] ) + length( $kv_ref->[1] ); 111 | tracer->debug( sprintf "Evicted header [%i] %s = %s\n", 112 | $n + 1, @$kv_ref ); 113 | push @evicted, [ $n, @$kv_ref ]; 114 | } 115 | return @evicted; 116 | } 117 | 118 | sub add_to_ht { 119 | my ( $context, $key, $value ) = @_; 120 | my $size = length($key) + length($value) + 32; 121 | return () if $size > $context->{max_ht_size}; 122 | 123 | my @evicted = evict_ht( $context, $size ); 124 | 125 | my $ht = $context->{header_table}; 126 | my $kv_ref = [ $key, $value ]; 127 | 128 | unshift @$ht, $kv_ref; 129 | $context->{ht_size} += $size; 130 | return @evicted; 131 | } 132 | 133 | sub headers_decode { 134 | my ( $con, $buf_ref, $buf_offset, $length, $stream_id ) = @_; 135 | 136 | my $context = $con->decode_context; 137 | 138 | my $ht = $context->{header_table}; 139 | my $eh = $context->{emitted_headers}; 140 | 141 | my $offset = 0; 142 | 143 | while ( $offset < $length ) { 144 | 145 | my $f = vec( $$buf_ref, $buf_offset + $offset, 8 ); 146 | tracer->debug( sprintf "\toffset: %d, byte: %02x\n", $offset, $f ); 147 | 148 | # Indexed Header 149 | if ( $f & 0x80 ) { 150 | my $size = 151 | int_decode( $buf_ref, $buf_offset + $offset, \my $index, 7 ); 152 | last unless $size; 153 | 154 | # DECODING ERROR 155 | if ( $index == 0 ) { 156 | tracer->error("Indexed header with zero index\n"); 157 | $con->error(COMPRESSION_ERROR); 158 | return undef; 159 | } 160 | 161 | tracer->debug("\tINDEXED($index) HEADER\t"); 162 | 163 | # Static table or Header Table entry 164 | if ( $index <= @stable ) { 165 | my ( $key, $value ) = @{ $stable[ $index - 1 ] }; 166 | push @$eh, $key, $value; 167 | tracer->debug("$key = $value\n"); 168 | } 169 | elsif ( $index > @stable + @$ht ) { 170 | tracer->error( 171 | "Indexed header with index out of header table: " 172 | . $index 173 | . "\n" ); 174 | $con->error(COMPRESSION_ERROR); 175 | return undef; 176 | } 177 | else { 178 | my $kv_ref = $ht->[ $index - @stable - 1 ]; 179 | 180 | push @$eh, @$kv_ref; 181 | tracer->debug("$kv_ref->[0] = $kv_ref->[1]\n"); 182 | } 183 | 184 | $offset += $size; 185 | } 186 | 187 | # Literal Header Field - New Name 188 | elsif ( $f == 0x40 || $f == 0x00 || $f == 0x10 ) { 189 | my $key_size = 190 | str_decode( $buf_ref, $buf_offset + $offset + 1, \my $key ); 191 | last unless $key_size; 192 | 193 | if ( $key_size == 1 ) { 194 | tracer->error("Empty literal header name"); 195 | $con->error(COMPRESSION_ERROR); 196 | return undef; 197 | } 198 | 199 | if ( $key =~ /[^a-z0-9\!\#\$\%\&\'\*\+\-\^\_\`]/ && $key !~ /^\:/ ) 200 | { 201 | tracer->warning("Illegal characters in header name"); 202 | $con->stream_error( $stream_id, PROTOCOL_ERROR ); 203 | return undef; 204 | } 205 | 206 | my $value_size = 207 | str_decode( $buf_ref, $buf_offset + $offset + 1 + $key_size, 208 | \my $value ); 209 | last unless $value_size; 210 | 211 | # Emitting header 212 | push @$eh, $key, $value; 213 | 214 | # Add to index 215 | if ( $f == 0x40 ) { 216 | add_to_ht( $context, $key, $value ); 217 | } 218 | tracer->debug( sprintf "\tLITERAL(new) HEADER\t%s: %s\n", 219 | $key, substr( $value, 0, 30 ) ); 220 | 221 | $offset += 1 + $key_size + $value_size; 222 | } 223 | 224 | # Literal Header Field - Indexed Name 225 | elsif (( $f & 0xC0 ) == 0x40 226 | || ( $f & 0xF0 ) == 0x00 227 | || ( $f & 0xF0 ) == 0x10 ) 228 | { 229 | my $size = int_decode( $buf_ref, $buf_offset + $offset, 230 | \my $index, ( $f & 0xC0 ) == 0x40 ? 6 : 4 ); 231 | last unless $size; 232 | 233 | my $value_size = 234 | str_decode( $buf_ref, $buf_offset + $offset + $size, \my $value ); 235 | last unless $value_size; 236 | 237 | my $key; 238 | 239 | if ( $index <= @stable ) { 240 | $key = $stable[ $index - 1 ]->[0]; 241 | } 242 | elsif ( $index > @stable + @$ht ) { 243 | tracer->error( 244 | "Literal header with index out of header table: " 245 | . $index 246 | . "\n" ); 247 | $con->error(COMPRESSION_ERROR); 248 | return undef; 249 | } 250 | else { 251 | $key = $ht->[ $index - @stable - 1 ]->[0]; 252 | } 253 | 254 | # Emitting header 255 | push @$eh, $key, $value; 256 | 257 | # Add to index 258 | if ( ( $f & 0xC0 ) == 0x40 ) { 259 | add_to_ht( $context, $key, $value ); 260 | } 261 | tracer->debug("\tLITERAL($index) HEADER\t$key: $value\n"); 262 | 263 | $offset += $size + $value_size; 264 | } 265 | 266 | # Encoding Context Update - Maximum Header Table Size change 267 | elsif ( ( $f & 0xE0 ) == 0x20 ) { 268 | my $size = 269 | int_decode( $buf_ref, $buf_offset + $offset, \my $ht_size, 5 ); 270 | last unless $size; 271 | 272 | # It's not possible to increase size of HEADER_TABLE 273 | if ( 274 | $ht_size > $context->{settings}->{&SETTINGS_HEADER_TABLE_SIZE} ) 275 | { 276 | tracer->error( "Peer attempt to increase " 277 | . "maximum header table size higher than current size: " 278 | . "$ht_size > " 279 | . $context->{settings}->{&SETTINGS_HEADER_TABLE_SIZE} ); 280 | $con->error(COMPRESSION_ERROR); 281 | return undef; 282 | } 283 | if (@$eh) { 284 | tracer->error( 285 | "Attempt to change header table size after headers"); 286 | $con->error(COMPRESSION_ERROR); 287 | return undef; 288 | } 289 | tracer->debug( "Update header table size from " 290 | . $context->{max_ht_size} . " to " 291 | . $ht_size ); 292 | $context->{max_ht_size} = $ht_size; 293 | evict_ht( $context, 0 ); 294 | $offset += $size; 295 | } 296 | 297 | # Encoding Error 298 | else { 299 | tracer->error( sprintf( "Unknown header type: %08b", $f ) ); 300 | $con->error(COMPRESSION_ERROR); 301 | return undef; 302 | } 303 | } 304 | 305 | if ( $offset != $length ) { 306 | tracer->error( 307 | "Headers decoding stopped at offset $offset of $length\n"); 308 | $con->error(COMPRESSION_ERROR); 309 | return undef; 310 | } 311 | 312 | return $offset; 313 | } 314 | 315 | sub headers_encode { 316 | my ( $context, $headers ) = @_; 317 | my $res = ''; 318 | my $ht = $context->{header_table}; 319 | my $sht = $context->{settings}->{&SETTINGS_HEADER_TABLE_SIZE}; 320 | 321 | # Encode dynamic table size update 322 | if ( $context->{max_ht_size} != $sht ) { 323 | $res .= int_encode( $sht, 5 ); 324 | vec( $res, 3, 2 ) = 0; 325 | vec( $res, 5, 1 ) = 1; 326 | $context->{max_ht_size} = $sht; 327 | } 328 | 329 | HLOOP: 330 | for my $n ( 0 .. $#$headers / 2 ) { 331 | my $header = lc( $headers->[ 2 * $n ] ); 332 | my $value = $headers->[ 2 * $n + 1 ]; 333 | my $hdr; 334 | 335 | tracer->debug("Encoding header: $header = $value\n"); 336 | 337 | for my $i ( 0 .. $#$ht ) { 338 | next 339 | unless $ht->[$i]->[0] eq $header 340 | && $ht->[$i]->[1] eq $value; 341 | $hdr = int_encode( $i + @stable + 1, 7 ); 342 | vec( $hdr, 7, 1 ) = 1; 343 | $res .= $hdr; 344 | tracer->debug( 345 | "\talready in header table, index " . ( $i + 1 ) . "\n" ); 346 | next HLOOP; 347 | } 348 | 349 | # 7.1 Indexed header field representation 350 | if ( exists $rstable{ $header . ' ' . $value } ) { 351 | $hdr = int_encode( $rstable{ $header . ' ' . $value }, 7 ); 352 | vec( $hdr, 7, 1 ) = 1; 353 | tracer->debug( "\tIndexed header " 354 | . $rstable{ $header . ' ' . $value } 355 | . " from table\n" ); 356 | } 357 | 358 | # 7.2.1 Literal Header Field with Incremental Indexing 359 | # (Indexed Name) 360 | elsif ( exists $rstable{ $header . ' ' } ) { 361 | $hdr = int_encode( $rstable{ $header . ' ' }, 6 ); 362 | vec( $hdr, 3, 2 ) = 1; 363 | $hdr .= str_encode($value); 364 | add_to_ht( $context, $header, $value ); 365 | tracer->debug( "\tLiteral header " 366 | . $rstable{ $header . ' ' } 367 | . " indexed name\n" ); 368 | } 369 | 370 | # 7.2.1 Literal Header Field with Incremental Indexing 371 | # (New Name) 372 | else { 373 | $hdr = pack( 'C', 0x40 ); 374 | $hdr .= str_encode($header) . str_encode($value); 375 | add_to_ht( $context, $header, $value ); 376 | tracer->debug("\tLiteral header new name\n"); 377 | } 378 | 379 | $res .= $hdr; 380 | } 381 | 382 | return $res; 383 | } 384 | 385 | 1; 386 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Huffman.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Huffman; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::HuffmanCodes; 5 | use Protocol::HTTP2::Trace qw(tracer); 6 | our ( %hcodes, %rhcodes, $hre ); 7 | require Exporter; 8 | our @ISA = qw(Exporter); 9 | our @EXPORT = qw(huffman_encode huffman_decode); 10 | 11 | # Memory unefficient algorithm (well suited for short strings) 12 | 13 | sub huffman_encode { 14 | my $s = shift; 15 | my $ret = my $bin = ''; 16 | for my $i ( 0 .. length($s) - 1 ) { 17 | $bin .= $hcodes{ ord( substr $s, $i, 1 ) }; 18 | } 19 | $bin .= substr( $hcodes{256}, 0, 8 - length($bin) % 8 ) if length($bin) % 8; 20 | return $ret . pack( 'B*', $bin ); 21 | } 22 | 23 | sub huffman_decode { 24 | my $s = shift; 25 | my $bin = unpack( 'B*', $s ); 26 | 27 | my $c = 0; 28 | $s = pack 'C*', map { $c += length; $rhcodes{$_} } ( $bin =~ /$hre/g ); 29 | tracer->warning( 30 | sprintf( 31 | "malformed data in string at position %i, " . " length: %i", 32 | $c, length($bin) 33 | ) 34 | ) if length($bin) - $c > 8; 35 | tracer->warning( 36 | sprintf "no huffman code 256 at the end of encoded string '%s': %s\n", 37 | substr( $s, 0, 30 ), 38 | substr( $bin, $c ) 39 | ) if $hcodes{256} !~ /^@{[ substr($bin, $c) ]}/; 40 | return $s; 41 | } 42 | 43 | 1; 44 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/HuffmanCodes.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::HuffmanCodes; 2 | use strict; 3 | use warnings; 4 | require Exporter; 5 | our @ISA = qw(Exporter); 6 | our ( %hcodes, %rhcodes, $hre ); 7 | our @EXPORT = qw(%hcodes %rhcodes $hre); 8 | 9 | %hcodes = ( 10 | 0 => '1111111111000', 11 | 1 => '11111111111111111011000', 12 | 2 => '1111111111111111111111100010', 13 | 3 => '1111111111111111111111100011', 14 | 4 => '1111111111111111111111100100', 15 | 5 => '1111111111111111111111100101', 16 | 6 => '1111111111111111111111100110', 17 | 7 => '1111111111111111111111100111', 18 | 8 => '1111111111111111111111101000', 19 | 9 => '111111111111111111101010', 20 | 10 => '111111111111111111111111111100', 21 | 11 => '1111111111111111111111101001', 22 | 12 => '1111111111111111111111101010', 23 | 13 => '111111111111111111111111111101', 24 | 14 => '1111111111111111111111101011', 25 | 15 => '1111111111111111111111101100', 26 | 16 => '1111111111111111111111101101', 27 | 17 => '1111111111111111111111101110', 28 | 18 => '1111111111111111111111101111', 29 | 19 => '1111111111111111111111110000', 30 | 20 => '1111111111111111111111110001', 31 | 21 => '1111111111111111111111110010', 32 | 22 => '111111111111111111111111111110', 33 | 23 => '1111111111111111111111110011', 34 | 24 => '1111111111111111111111110100', 35 | 25 => '1111111111111111111111110101', 36 | 26 => '1111111111111111111111110110', 37 | 27 => '1111111111111111111111110111', 38 | 28 => '1111111111111111111111111000', 39 | 29 => '1111111111111111111111111001', 40 | 30 => '1111111111111111111111111010', 41 | 31 => '1111111111111111111111111011', 42 | 32 => '010100', 43 | 33 => '1111111000', 44 | 34 => '1111111001', 45 | 35 => '111111111010', 46 | 36 => '1111111111001', 47 | 37 => '010101', 48 | 38 => '11111000', 49 | 39 => '11111111010', 50 | 40 => '1111111010', 51 | 41 => '1111111011', 52 | 42 => '11111001', 53 | 43 => '11111111011', 54 | 44 => '11111010', 55 | 45 => '010110', 56 | 46 => '010111', 57 | 47 => '011000', 58 | 48 => '00000', 59 | 49 => '00001', 60 | 50 => '00010', 61 | 51 => '011001', 62 | 52 => '011010', 63 | 53 => '011011', 64 | 54 => '011100', 65 | 55 => '011101', 66 | 56 => '011110', 67 | 57 => '011111', 68 | 58 => '1011100', 69 | 59 => '11111011', 70 | 60 => '111111111111100', 71 | 61 => '100000', 72 | 62 => '111111111011', 73 | 63 => '1111111100', 74 | 64 => '1111111111010', 75 | 65 => '100001', 76 | 66 => '1011101', 77 | 67 => '1011110', 78 | 68 => '1011111', 79 | 69 => '1100000', 80 | 70 => '1100001', 81 | 71 => '1100010', 82 | 72 => '1100011', 83 | 73 => '1100100', 84 | 74 => '1100101', 85 | 75 => '1100110', 86 | 76 => '1100111', 87 | 77 => '1101000', 88 | 78 => '1101001', 89 | 79 => '1101010', 90 | 80 => '1101011', 91 | 81 => '1101100', 92 | 82 => '1101101', 93 | 83 => '1101110', 94 | 84 => '1101111', 95 | 85 => '1110000', 96 | 86 => '1110001', 97 | 87 => '1110010', 98 | 88 => '11111100', 99 | 89 => '1110011', 100 | 90 => '11111101', 101 | 91 => '1111111111011', 102 | 92 => '1111111111111110000', 103 | 93 => '1111111111100', 104 | 94 => '11111111111100', 105 | 95 => '100010', 106 | 96 => '111111111111101', 107 | 97 => '00011', 108 | 98 => '100011', 109 | 99 => '00100', 110 | 100 => '100100', 111 | 101 => '00101', 112 | 102 => '100101', 113 | 103 => '100110', 114 | 104 => '100111', 115 | 105 => '00110', 116 | 106 => '1110100', 117 | 107 => '1110101', 118 | 108 => '101000', 119 | 109 => '101001', 120 | 110 => '101010', 121 | 111 => '00111', 122 | 112 => '101011', 123 | 113 => '1110110', 124 | 114 => '101100', 125 | 115 => '01000', 126 | 116 => '01001', 127 | 117 => '101101', 128 | 118 => '1110111', 129 | 119 => '1111000', 130 | 120 => '1111001', 131 | 121 => '1111010', 132 | 122 => '1111011', 133 | 123 => '111111111111110', 134 | 124 => '11111111100', 135 | 125 => '11111111111101', 136 | 126 => '1111111111101', 137 | 127 => '1111111111111111111111111100', 138 | 128 => '11111111111111100110', 139 | 129 => '1111111111111111010010', 140 | 130 => '11111111111111100111', 141 | 131 => '11111111111111101000', 142 | 132 => '1111111111111111010011', 143 | 133 => '1111111111111111010100', 144 | 134 => '1111111111111111010101', 145 | 135 => '11111111111111111011001', 146 | 136 => '1111111111111111010110', 147 | 137 => '11111111111111111011010', 148 | 138 => '11111111111111111011011', 149 | 139 => '11111111111111111011100', 150 | 140 => '11111111111111111011101', 151 | 141 => '11111111111111111011110', 152 | 142 => '111111111111111111101011', 153 | 143 => '11111111111111111011111', 154 | 144 => '111111111111111111101100', 155 | 145 => '111111111111111111101101', 156 | 146 => '1111111111111111010111', 157 | 147 => '11111111111111111100000', 158 | 148 => '111111111111111111101110', 159 | 149 => '11111111111111111100001', 160 | 150 => '11111111111111111100010', 161 | 151 => '11111111111111111100011', 162 | 152 => '11111111111111111100100', 163 | 153 => '111111111111111011100', 164 | 154 => '1111111111111111011000', 165 | 155 => '11111111111111111100101', 166 | 156 => '1111111111111111011001', 167 | 157 => '11111111111111111100110', 168 | 158 => '11111111111111111100111', 169 | 159 => '111111111111111111101111', 170 | 160 => '1111111111111111011010', 171 | 161 => '111111111111111011101', 172 | 162 => '11111111111111101001', 173 | 163 => '1111111111111111011011', 174 | 164 => '1111111111111111011100', 175 | 165 => '11111111111111111101000', 176 | 166 => '11111111111111111101001', 177 | 167 => '111111111111111011110', 178 | 168 => '11111111111111111101010', 179 | 169 => '1111111111111111011101', 180 | 170 => '1111111111111111011110', 181 | 171 => '111111111111111111110000', 182 | 172 => '111111111111111011111', 183 | 173 => '1111111111111111011111', 184 | 174 => '11111111111111111101011', 185 | 175 => '11111111111111111101100', 186 | 176 => '111111111111111100000', 187 | 177 => '111111111111111100001', 188 | 178 => '1111111111111111100000', 189 | 179 => '111111111111111100010', 190 | 180 => '11111111111111111101101', 191 | 181 => '1111111111111111100001', 192 | 182 => '11111111111111111101110', 193 | 183 => '11111111111111111101111', 194 | 184 => '11111111111111101010', 195 | 185 => '1111111111111111100010', 196 | 186 => '1111111111111111100011', 197 | 187 => '1111111111111111100100', 198 | 188 => '11111111111111111110000', 199 | 189 => '1111111111111111100101', 200 | 190 => '1111111111111111100110', 201 | 191 => '11111111111111111110001', 202 | 192 => '11111111111111111111100000', 203 | 193 => '11111111111111111111100001', 204 | 194 => '11111111111111101011', 205 | 195 => '1111111111111110001', 206 | 196 => '1111111111111111100111', 207 | 197 => '11111111111111111110010', 208 | 198 => '1111111111111111101000', 209 | 199 => '1111111111111111111101100', 210 | 200 => '11111111111111111111100010', 211 | 201 => '11111111111111111111100011', 212 | 202 => '11111111111111111111100100', 213 | 203 => '111111111111111111111011110', 214 | 204 => '111111111111111111111011111', 215 | 205 => '11111111111111111111100101', 216 | 206 => '111111111111111111110001', 217 | 207 => '1111111111111111111101101', 218 | 208 => '1111111111111110010', 219 | 209 => '111111111111111100011', 220 | 210 => '11111111111111111111100110', 221 | 211 => '111111111111111111111100000', 222 | 212 => '111111111111111111111100001', 223 | 213 => '11111111111111111111100111', 224 | 214 => '111111111111111111111100010', 225 | 215 => '111111111111111111110010', 226 | 216 => '111111111111111100100', 227 | 217 => '111111111111111100101', 228 | 218 => '11111111111111111111101000', 229 | 219 => '11111111111111111111101001', 230 | 220 => '1111111111111111111111111101', 231 | 221 => '111111111111111111111100011', 232 | 222 => '111111111111111111111100100', 233 | 223 => '111111111111111111111100101', 234 | 224 => '11111111111111101100', 235 | 225 => '111111111111111111110011', 236 | 226 => '11111111111111101101', 237 | 227 => '111111111111111100110', 238 | 228 => '1111111111111111101001', 239 | 229 => '111111111111111100111', 240 | 230 => '111111111111111101000', 241 | 231 => '11111111111111111110011', 242 | 232 => '1111111111111111101010', 243 | 233 => '1111111111111111101011', 244 | 234 => '1111111111111111111101110', 245 | 235 => '1111111111111111111101111', 246 | 236 => '111111111111111111110100', 247 | 237 => '111111111111111111110101', 248 | 238 => '11111111111111111111101010', 249 | 239 => '11111111111111111110100', 250 | 240 => '11111111111111111111101011', 251 | 241 => '111111111111111111111100110', 252 | 242 => '11111111111111111111101100', 253 | 243 => '11111111111111111111101101', 254 | 244 => '111111111111111111111100111', 255 | 245 => '111111111111111111111101000', 256 | 246 => '111111111111111111111101001', 257 | 247 => '111111111111111111111101010', 258 | 248 => '111111111111111111111101011', 259 | 249 => '1111111111111111111111111110', 260 | 250 => '111111111111111111111101100', 261 | 251 => '111111111111111111111101101', 262 | 252 => '111111111111111111111101110', 263 | 253 => '111111111111111111111101111', 264 | 254 => '111111111111111111111110000', 265 | 255 => '11111111111111111111101110', 266 | 256 => '111111111111111111111111111111', 267 | ); 268 | 269 | %rhcodes = reverse %hcodes; 270 | 271 | { 272 | local $" = '|'; 273 | $hre = qr/(?:^|\G)(@{[ keys %rhcodes ]})/; 274 | } 275 | 276 | 1; 277 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Server.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Server; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Connection; 5 | use Protocol::HTTP2::Constants qw(:frame_types :flags :states :endpoints 6 | :settings :limits const_name); 7 | use Protocol::HTTP2::Trace qw(tracer); 8 | use Carp; 9 | use Scalar::Util (); 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 = Protocol::HTTP2::Client->new( %options ); 112 | 113 | Available 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 | 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 | 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 | 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 | 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 | 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 | 348 | sub 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 | 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' => 'localhost: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 | 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 | 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 | 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 | 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 | 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 | 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 | 553 | Send ping frame to client (to keep connection alive) 554 | 555 | $server->ping 556 | 557 | or 558 | 559 | $server->ping($payload); 560 | 561 | Payload can be arbitrary binary string and must contain 8 octets. If payload argument 562 | is omitted server will send random data. 563 | 564 | =cut 565 | 566 | sub ping { 567 | shift->{con}->send_ping(@_); 568 | } 569 | 570 | 1; 571 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/StaticTable.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::StaticTable; 2 | use strict; 3 | use warnings; 4 | require Exporter; 5 | our @ISA = qw(Exporter); 6 | our ( @stable, %rstable ); 7 | our @EXPORT = qw(@stable %rstable); 8 | 9 | @stable = ( 10 | [ ":authority", "" ], 11 | [ ":method", "GET" ], 12 | [ ":method", "POST" ], 13 | [ ":path", "/" ], 14 | [ ":path", "/index.html" ], 15 | [ ":scheme", "http" ], 16 | [ ":scheme", "https" ], 17 | [ ":status", "200" ], 18 | [ ":status", "204" ], 19 | [ ":status", "206" ], 20 | [ ":status", "304" ], 21 | [ ":status", "400" ], 22 | [ ":status", "404" ], 23 | [ ":status", "500" ], 24 | [ "accept-charset", "" ], 25 | [ "accept-encoding", "gzip, deflate" ], 26 | [ "accept-language", "" ], 27 | [ "accept-ranges", "" ], 28 | [ "accept", "" ], 29 | [ "access-control-allow-origin", "" ], 30 | [ "age", "" ], 31 | [ "allow", "" ], 32 | [ "authorization", "" ], 33 | [ "cache-control", "" ], 34 | [ "content-disposition", "" ], 35 | [ "content-encoding", "" ], 36 | [ "content-language", "" ], 37 | [ "content-length", "" ], 38 | [ "content-location", "" ], 39 | [ "content-range", "" ], 40 | [ "content-type", "" ], 41 | [ "cookie", "" ], 42 | [ "date", "" ], 43 | [ "etag", "" ], 44 | [ "expect", "" ], 45 | [ "expires", "" ], 46 | [ "from", "" ], 47 | [ "host", "" ], 48 | [ "if-match", "" ], 49 | [ "if-modified-since", "" ], 50 | [ "if-none-match", "" ], 51 | [ "if-range", "" ], 52 | [ "if-unmodified-since", "" ], 53 | [ "last-modified", "" ], 54 | [ "link", "" ], 55 | [ "location", "" ], 56 | [ "max-forwards", "" ], 57 | [ "proxy-authenticate", "" ], 58 | [ "proxy-authorization", "" ], 59 | [ "range", "" ], 60 | [ "referer", "" ], 61 | [ "refresh", "" ], 62 | [ "retry-after", "" ], 63 | [ "server", "" ], 64 | [ "set-cookie", "" ], 65 | [ "strict-transport-security", "" ], 66 | [ "transfer-encoding", "" ], 67 | [ "user-agent", "" ], 68 | [ "vary", "" ], 69 | [ "via", "" ], 70 | [ "www-authenticate", "" ], 71 | ); 72 | 73 | for my $k ( 0 .. $#stable ) { 74 | my $key = join ' ', @{ $stable[$k] }; 75 | $rstable{$key} = $k + 1; 76 | $rstable{ $stable[$k]->[0] . ' ' } = $k + 1 77 | if ( $stable[$k]->[1] ne '' 78 | && !exists $rstable{ $stable[$k]->[0] . ' ' } ); 79 | } 80 | 81 | 1; 82 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Stream.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Stream; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Constants qw(:states :endpoints :settings :frame_types 5 | :limits :errors); 6 | use Protocol::HTTP2::HeaderCompression qw( headers_decode ); 7 | use Protocol::HTTP2::Trace qw(tracer); 8 | 9 | # Streams related part of Protocol::HTTP2::Conntection 10 | 11 | # Autogen properties 12 | { 13 | no strict 'refs'; 14 | for my $prop ( 15 | qw(promised_sid headers pp_headers header_block trailer 16 | trailer_headers length blocked_data weight end reset) 17 | ) 18 | { 19 | *{ __PACKAGE__ . '::stream_' . $prop } = sub { 20 | return 21 | !exists $_[0]->{streams}->{ $_[1] } ? undef 22 | : @_ == 2 ? $_[0]->{streams}->{ $_[1] }->{$prop} 23 | : ( $_[0]->{streams}->{ $_[1] }->{$prop} = $_[2] ); 24 | } 25 | } 26 | } 27 | 28 | sub new_stream { 29 | my $self = shift; 30 | return undef if $self->goaway; 31 | 32 | $self->{last_stream} += 2 33 | if exists $self->{streams}->{ $self->{type} == CLIENT ? 1 : 2 }; 34 | $self->{streams}->{ $self->{last_stream} } = { 35 | 'state' => IDLE, 36 | 'weight' => DEFAULT_WEIGHT, 37 | 'stream_dep' => 0, 38 | 'fcw_recv' => $self->dec_setting(SETTINGS_INITIAL_WINDOW_SIZE), 39 | 'fcw_send' => $self->enc_setting(SETTINGS_INITIAL_WINDOW_SIZE), 40 | }; 41 | return $self->{last_stream}; 42 | } 43 | 44 | sub new_peer_stream { 45 | my $self = shift; 46 | my $stream_id = shift; 47 | if ( $stream_id < $self->{last_peer_stream} 48 | || ( $stream_id % 2 ) == ( $self->{type} == CLIENT ) ? 1 : 0 49 | || $self->goaway ) 50 | { 51 | tracer->error("Peer send invalid stream id: $stream_id\n"); 52 | $self->error(PROTOCOL_ERROR); 53 | return undef; 54 | } 55 | $self->{last_peer_stream} = $stream_id; 56 | if ( $self->dec_setting(SETTINGS_MAX_CONCURRENT_STREAMS) <= 57 | $self->{active_peer_streams} ) 58 | { 59 | tracer->warning("SETTINGS_MAX_CONCURRENT_STREAMS exceeded\n"); 60 | $self->stream_error( $stream_id, REFUSED_STREAM ); 61 | return undef; 62 | } 63 | $self->{active_peer_streams}++; 64 | tracer->debug("Active streams: $self->{active_peer_streams}"); 65 | $self->{streams}->{$stream_id} = { 66 | 'state' => IDLE, 67 | 'weight' => DEFAULT_WEIGHT, 68 | 'stream_dep' => 0, 69 | 'fcw_recv' => $self->dec_setting(SETTINGS_INITIAL_WINDOW_SIZE), 70 | 'fcw_send' => $self->enc_setting(SETTINGS_INITIAL_WINDOW_SIZE), 71 | }; 72 | $self->{on_new_peer_stream}->($stream_id) 73 | if exists $self->{on_new_peer_stream}; 74 | 75 | return $self->{last_peer_stream}; 76 | } 77 | 78 | sub stream { 79 | my ( $self, $stream_id ) = @_; 80 | return undef unless exists $self->{streams}->{$stream_id}; 81 | 82 | $self->{streams}->{$stream_id}; 83 | } 84 | 85 | # stream_state ( $self, $stream_id, $new_state?, $pending? ) 86 | 87 | sub stream_state { 88 | my $self = shift; 89 | my $stream_id = shift; 90 | return undef unless exists $self->{streams}->{$stream_id}; 91 | my $s = $self->{streams}->{$stream_id}; 92 | 93 | if (@_) { 94 | my ( $new_state, $pending ) = @_; 95 | 96 | if ($pending) { 97 | $self->stream_pending_state( $stream_id, $new_state ); 98 | } 99 | else { 100 | $self->{on_change_state}->( $stream_id, $s->{state}, $new_state ) 101 | if exists $self->{on_change_state}; 102 | 103 | $s->{state} = $new_state; 104 | 105 | # Exec callbacks for new state 106 | if ( exists $s->{cb} && exists $s->{cb}->{ $s->{state} } ) { 107 | for my $cb ( @{ $s->{cb}->{ $s->{state} } } ) { 108 | $cb->(); 109 | } 110 | } 111 | 112 | # Cleanup 113 | if ( $new_state == CLOSED ) { 114 | $self->{active_peer_streams}-- 115 | if $self->{active_peer_streams} 116 | && ( ( $stream_id % 2 ) ^ ( $self->{type} == CLIENT ) ); 117 | tracer->info( 118 | "Active streams: $self->{active_peer_streams} $stream_id"); 119 | for my $key ( keys %$s ) { 120 | next if grep { $key eq $_ } ( 121 | qw(state weight stream_dep 122 | fcw_recv fcw_send reset) 123 | ); 124 | delete $s->{$key}; 125 | } 126 | } 127 | } 128 | } 129 | 130 | $s->{state}; 131 | } 132 | 133 | sub stream_pending_state { 134 | my $self = shift; 135 | my $stream_id = shift; 136 | return undef unless exists $self->{streams}->{$stream_id}; 137 | my $s = $self->{streams}->{$stream_id}; 138 | if (@_) { 139 | $s->{pending_state} = shift; 140 | $self->{pending_stream} = 141 | defined $s->{pending_state} ? $stream_id : undef; 142 | } 143 | $s->{pending_state}; 144 | } 145 | 146 | sub stream_cb { 147 | my ( $self, $stream_id, $state, $cb ) = @_; 148 | 149 | return undef unless exists $self->{streams}->{$stream_id}; 150 | 151 | push @{ $self->{streams}->{$stream_id}->{cb}->{$state} }, $cb; 152 | } 153 | 154 | sub stream_frame_cb { 155 | my ( $self, $stream_id, $frame, $cb ) = @_; 156 | 157 | return undef unless exists $self->{streams}->{$stream_id}; 158 | 159 | push @{ $self->{streams}->{$stream_id}->{frame_cb}->{$frame} }, $cb; 160 | } 161 | 162 | sub stream_data { 163 | my $self = shift; 164 | my $stream_id = shift; 165 | return undef unless exists $self->{streams}->{$stream_id}; 166 | my $s = $self->{streams}->{$stream_id}; 167 | 168 | if (@_) { 169 | 170 | # Exec callbacks for data 171 | if ( exists $s->{frame_cb} && exists $s->{frame_cb}->{&DATA} ) { 172 | for my $cb ( @{ $s->{frame_cb}->{&DATA} } ) { 173 | $cb->( $_[0] ); 174 | } 175 | } 176 | else { 177 | $s->{data} .= shift; 178 | } 179 | } 180 | 181 | $s->{data}; 182 | } 183 | 184 | sub stream_headers_done { 185 | my $self = shift; 186 | my $stream_id = shift; 187 | return undef unless exists $self->{streams}->{$stream_id}; 188 | my $s = $self->{streams}->{$stream_id}; 189 | 190 | my $res = 191 | headers_decode( $self, \$s->{header_block}, 0, 192 | length $s->{header_block}, $stream_id ); 193 | 194 | tracer->debug("Headers done for stream $stream_id\n"); 195 | 196 | return undef unless defined $res; 197 | 198 | # Clear header_block 199 | $s->{header_block} = ''; 200 | 201 | my $eh = $self->decode_context->{emitted_headers}; 202 | my $is_response = $self->{type} == CLIENT && !$s->{promised_sid}; 203 | my $is_trailer = !!$self->stream_trailer($stream_id); 204 | 205 | return undef 206 | unless $self->validate_headers( $eh, $stream_id, $is_response ); 207 | 208 | if ( $s->{promised_sid} ) { 209 | $self->{streams}->{ $s->{promised_sid} }->{pp_headers} = $eh; 210 | } 211 | elsif ($is_trailer) { 212 | $self->stream_trailer_headers( $stream_id, $eh ); 213 | } 214 | else { 215 | $s->{headers} = $eh; 216 | } 217 | 218 | # Exec callbacks for headers 219 | if ( exists $s->{frame_cb} && exists $s->{frame_cb}->{&HEADERS} ) { 220 | for my $cb ( @{ $s->{frame_cb}->{&HEADERS} } ) { 221 | $cb->($eh); 222 | } 223 | } 224 | 225 | # Clear emitted headers 226 | $self->decode_context->{emitted_headers} = []; 227 | 228 | return 1; 229 | } 230 | 231 | sub validate_headers { 232 | my ( $self, $headers, $stream_id, $is_response ) = @_; 233 | my $pseudo_flag = 1; 234 | my %pseudo_hash = (); 235 | my @h = $is_response ? (qw(:status)) : ( 236 | qw(:method :scheme :authority 237 | :path) 238 | ); 239 | 240 | # Trailer headers ? 241 | if ( my $t = $self->stream_trailer($stream_id) ) { 242 | for my $i ( 0 .. @$headers / 2 - 1 ) { 243 | my ( $h, $v ) = ( $headers->[ $i * 2 ], $headers->[ $i * 2 + 1 ] ); 244 | if ( !exists $t->{$h} ) { 245 | tracer->warning( 246 | "header <$h> doesn't listed in the trailer header"); 247 | $self->stream_error( $stream_id, PROTOCOL_ERROR ); 248 | return undef; 249 | } 250 | } 251 | return 1; 252 | } 253 | 254 | for my $i ( 0 .. @$headers / 2 - 1 ) { 255 | my ( $h, $v ) = ( $headers->[ $i * 2 ], $headers->[ $i * 2 + 1 ] ); 256 | if ( $h =~ /^\:/ ) { 257 | if ( !$pseudo_flag ) { 258 | tracer->warning( 259 | "pseudo-header <$h> appears after a regular header"); 260 | $self->stream_error( $stream_id, PROTOCOL_ERROR ); 261 | return undef; 262 | } 263 | elsif ( !grep { $_ eq $h } @h ) { 264 | tracer->warning("invalid pseudo-header <$h>"); 265 | $self->stream_error( $stream_id, PROTOCOL_ERROR ); 266 | return undef; 267 | } 268 | elsif ( exists $pseudo_hash{$h} ) { 269 | tracer->warning("repeated pseudo-header <$h>"); 270 | $self->stream_error( $stream_id, PROTOCOL_ERROR ); 271 | return undef; 272 | } 273 | 274 | $pseudo_hash{$h} = $v; 275 | next; 276 | } 277 | 278 | $pseudo_flag = 0 if $pseudo_flag; 279 | 280 | if ( $h eq 'connection' ) { 281 | tracer->warning("connection header is not valid in http/2"); 282 | $self->stream_error( $stream_id, PROTOCOL_ERROR ); 283 | return undef; 284 | } 285 | elsif ( $h eq 'te' && $v ne 'trailers' ) { 286 | tracer->warning("TE header can contain only value 'trailers'"); 287 | $self->stream_error( $stream_id, PROTOCOL_ERROR ); 288 | return undef; 289 | } 290 | elsif ( $h eq 'content-length' ) { 291 | $self->stream_length( $stream_id, $v ); 292 | } 293 | elsif ( $h eq 'trailer' ) { 294 | my %th = map { $_ => 1 } split /\s*,\s*/, lc($v); 295 | if ( 296 | grep { exists $th{$_} } ( 297 | qw(transfer-encoding content-length host authentication 298 | cache-control expect max-forwards pragma range te 299 | content-encoding content-type content-range trailer) 300 | ) 301 | ) 302 | { 303 | tracer->warning("trailer header contain forbidden headers"); 304 | $self->stream_error( $stream_id, PROTOCOL_ERROR ); 305 | return undef; 306 | } 307 | $self->stream_trailer( $stream_id, {%th} ); 308 | } 309 | } 310 | 311 | for my $h (@h) { 312 | next if exists $pseudo_hash{$h}; 313 | 314 | tracer->warning("missed mandatory pseudo-header $h"); 315 | $self->stream_error( $stream_id, PROTOCOL_ERROR ); 316 | return undef; 317 | } 318 | 319 | 1; 320 | } 321 | 322 | # RST_STREAM for stream errors 323 | sub stream_error { 324 | my ( $self, $stream_id, $error ) = @_; 325 | $self->enqueue( RST_STREAM, 0, $stream_id, $error ); 326 | } 327 | 328 | # Flow control windown of stream 329 | sub _stream_fcw { 330 | my $dir = shift; 331 | my $self = shift; 332 | my $stream_id = shift; 333 | return undef unless exists $self->{streams}->{$stream_id}; 334 | my $s = $self->{streams}->{$stream_id}; 335 | 336 | if (@_) { 337 | $s->{$dir} += shift; 338 | tracer->debug( "Stream $stream_id $dir now is " . $s->{$dir} . "\n" ); 339 | } 340 | $s->{$dir}; 341 | } 342 | 343 | sub stream_fcw_send { 344 | _stream_fcw( 'fcw_send', @_ ); 345 | } 346 | 347 | sub stream_fcw_recv { 348 | _stream_fcw( 'fcw_recv', @_ ); 349 | } 350 | 351 | sub stream_fcw_update { 352 | my ( $self, $stream_id ) = @_; 353 | 354 | # TODO: check size of data of stream in memory 355 | my $size = $self->dec_setting(SETTINGS_INITIAL_WINDOW_SIZE); 356 | tracer->debug("update fcw recv of stream $stream_id with $size b.\n"); 357 | $self->stream_fcw_recv( $stream_id, $size ); 358 | $self->enqueue( WINDOW_UPDATE, 0, $stream_id, $size ); 359 | } 360 | 361 | sub stream_send_blocked { 362 | my ( $self, $stream_id ) = @_; 363 | my $s = $self->{streams}->{$stream_id} or return undef; 364 | 365 | if ( defined( $s->{blocked_data} ) && length( $s->{blocked_data} ) 366 | && $self->stream_fcw_send($stream_id) > 0 ) 367 | { 368 | $self->send_data($stream_id); 369 | } 370 | } 371 | 372 | sub stream_reprio { 373 | my ( $self, $stream_id, $exclusive, $stream_dep ) = @_; 374 | return undef 375 | unless exists $self->{streams}->{$stream_id} 376 | && ( $stream_dep == 0 || exists $self->{streams}->{$stream_dep} ) 377 | && $stream_id != $stream_dep; 378 | my $s = $self->{streams}; 379 | 380 | if ( $s->{$stream_id}->{stream_dep} != $stream_dep ) { 381 | 382 | # check if new stream_dep is stream child 383 | if ( $stream_dep != 0 ) { 384 | my $sid = $stream_dep; 385 | while ( $sid = $s->{$sid}->{stream_dep} ) { 386 | next unless $sid == $stream_id; 387 | 388 | # Child take my stream dep 389 | $s->{$stream_dep}->{stream_dep} = 390 | $s->{$stream_id}->{stream_dep}; 391 | last; 392 | } 393 | } 394 | 395 | # Set new stream dep 396 | $s->{$stream_id}->{stream_dep} = $stream_dep; 397 | } 398 | 399 | if ($exclusive) { 400 | 401 | # move all siblings to children 402 | for my $sid ( keys %$s ) { 403 | next 404 | if $s->{$sid}->{stream_dep} != $stream_dep 405 | || $sid == $stream_id; 406 | 407 | $s->{$sid}->{stream_dep} = $stream_id; 408 | } 409 | } 410 | 411 | return 1; 412 | } 413 | 414 | 1; 415 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Trace.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Trace; 2 | use strict; 3 | use warnings; 4 | use Time::HiRes qw(time); 5 | 6 | use Exporter qw(import); 7 | our @EXPORT_OK = qw(tracer bin2hex); 8 | 9 | my %levels = ( 10 | debug => 0, 11 | info => 1, 12 | notice => 2, 13 | warning => 3, 14 | error => 4, 15 | critical => 5, 16 | alert => 6, 17 | emergency => 7, 18 | ); 19 | 20 | my $tracer_sngl = Protocol::HTTP2::Trace->_new( 21 | min_level => 22 | ( exists $ENV{HTTP2_DEBUG} && exists $levels{ $ENV{HTTP2_DEBUG} } ) 23 | ? $levels{ $ENV{HTTP2_DEBUG} } 24 | : $levels{error} 25 | ); 26 | my $start_time = 0; 27 | 28 | sub tracer { 29 | $tracer_sngl; 30 | } 31 | 32 | sub _new { 33 | my ( $class, %opts ) = @_; 34 | bless {%opts}, $class; 35 | } 36 | 37 | sub _log { 38 | my ( $self, $level, $message ) = @_; 39 | $level = uc($level); 40 | chomp($message); 41 | my $now = time; 42 | if ( $now - $start_time < 60 ) { 43 | $message =~ s/\n/\n /g; 44 | printf "[%05.3f] %s %s\n", $now - $start_time, $level, $message; 45 | } 46 | else { 47 | my @t = ( localtime() )[ 5, 4, 3, 2, 1, 0 ]; 48 | $t[0] += 1900; 49 | $t[1]++; 50 | $message =~ s/\n/\n /g; 51 | printf "[%4d-%02d-%02d %02d:%02d:%02d] %s %s\n", @t, $level, $message; 52 | $start_time = $now; 53 | } 54 | } 55 | 56 | { 57 | no strict 'refs'; 58 | for my $l ( keys %levels ) { 59 | *{ __PACKAGE__ . "::" . $l } = 60 | ( $levels{$l} >= $tracer_sngl->{min_level} ) 61 | ? sub { 62 | shift->_log( $l, @_ ); 63 | } 64 | : sub { 1 } 65 | } 66 | } 67 | 68 | sub bin2hex { 69 | my $bin = shift; 70 | my $c = 0; 71 | my $s; 72 | 73 | join "", map { 74 | $c++; 75 | $s = !( $c % 16 ) ? "\n" : ( $c % 2 ) ? "" : " "; 76 | $_ . $s 77 | } unpack( "(H2)*", $bin ); 78 | } 79 | 80 | 1; 81 | -------------------------------------------------------------------------------- /lib/Protocol/HTTP2/Upgrade.pm: -------------------------------------------------------------------------------- 1 | package Protocol::HTTP2::Upgrade; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2; 5 | use Protocol::HTTP2::Constants qw(:frame_types :errors :states); 6 | use Protocol::HTTP2::Trace qw(tracer); 7 | use MIME::Base64 qw(encode_base64url decode_base64url); 8 | 9 | #use re 'debug'; 10 | my $end_headers_re = qr/\G.+?\x0d?\x0a\x0d?\x0a/s; 11 | my $header_re = qr/\G[ \t]*(.+?)[ \t]*\:[ \t]*(.+?)[ \t]*\x0d?\x0a/; 12 | 13 | sub upgrade_request { 14 | my ( $con, %h ) = @_; 15 | my $request = sprintf "%s %s HTTP/1.1\x0d\x0aHost: %s\x0d\x0a", 16 | $h{':method'}, $h{':path'}, 17 | $h{':authority'}; 18 | while ( my ( $h, $v ) = splice( @{ $h{headers} }, 0, 2 ) ) { 19 | next if grep { lc($h) eq $_ } (qw(connection upgrade http2-settings)); 20 | $request .= $h . ': ' . $v . "\x0d\x0a"; 21 | } 22 | $request .= join "\x0d\x0a", 23 | 'Connection: Upgrade, HTTP2-Settings', 24 | 'Upgrade: ' . Protocol::HTTP2::ident_plain, 25 | 'HTTP2-Settings: ' 26 | . encode_base64url( $con->frame_encode( SETTINGS, 0, 0, {} ) ), 27 | '', ''; 28 | } 29 | 30 | sub upgrade_response { 31 | 32 | join "\x0d\x0a", 33 | "HTTP/1.1 101 Switching Protocols", 34 | "Connection: Upgrade", 35 | "Upgrade: " . Protocol::HTTP2::ident_plain, 36 | "", ""; 37 | 38 | } 39 | 40 | sub decode_upgrade_request { 41 | my ( $con, $buf_ref, $buf_offset, $headers_ref ) = @_; 42 | 43 | pos($$buf_ref) = $buf_offset; 44 | 45 | # Search end of headers 46 | return 0 if $$buf_ref !~ /$end_headers_re/g; 47 | my $end_headers_pos = pos($$buf_ref) - $buf_offset; 48 | 49 | pos($$buf_ref) = $buf_offset; 50 | 51 | # Request 52 | return undef if $$buf_ref !~ m#\G(\w+) ([^ ]+) HTTP/1\.1\x0d?\x0a#g; 53 | my ( $method, $uri ) = ( $1, $2 ); 54 | 55 | # TODO: remove after http2 -> http/1.1 headers conversion implemented 56 | push @$headers_ref, ":method", $method; 57 | push @$headers_ref, ":path", $uri; 58 | push @$headers_ref, ":scheme", 'http'; 59 | 60 | my $success = 0; 61 | 62 | # Parse headers 63 | while ( $success != 0b111 && $$buf_ref =~ /$header_re/gc ) { 64 | my ( $header, $value ) = ( lc($1), $2 ); 65 | 66 | if ( $header eq "connection" ) { 67 | my %h = map { $_ => 1 } split /\s*,\s*/, lc($value); 68 | $success |= 0b001 69 | if exists $h{'upgrade'} && exists $h{'http2-settings'}; 70 | } 71 | elsif ( 72 | $header eq "upgrade" && grep { $_ eq Protocol::HTTP2::ident_plain } 73 | split /\s*,\s*/, 74 | $value 75 | ) 76 | { 77 | $success |= 0b010; 78 | } 79 | elsif ( $header eq "http2-settings" 80 | && defined $con->frame_decode( \decode_base64url($value), 0 ) ) 81 | { 82 | $success |= 0b100; 83 | } 84 | else { 85 | push @$headers_ref, $header, $value; 86 | } 87 | } 88 | 89 | return undef unless $success == 0b111; 90 | 91 | # TODO: method POST also can contain data... 92 | 93 | return $end_headers_pos; 94 | 95 | } 96 | 97 | sub decode_upgrade_response { 98 | my ( $con, $buf_ref, $buf_offset ) = @_; 99 | 100 | pos($$buf_ref) = $buf_offset; 101 | 102 | # Search end of headers 103 | return 0 if $$buf_ref !~ /$end_headers_re/g; 104 | my $end_headers_pos = pos($$buf_ref) - $buf_offset; 105 | 106 | pos($$buf_ref) = $buf_offset; 107 | 108 | # Switch Protocols failed 109 | return undef if $$buf_ref !~ m#\GHTTP/1\.1 101 .+?\x0d?\x0a#g; 110 | 111 | my $success = 0; 112 | 113 | # Parse headers 114 | while ( $success != 0b11 && $$buf_ref =~ /$header_re/gc ) { 115 | my ( $header, $value ) = ( lc($1), $2 ); 116 | 117 | if ( $header eq "connection" && lc($value) eq "upgrade" ) { 118 | $success |= 0b01; 119 | } 120 | elsif ( $header eq "upgrade" && $value eq Protocol::HTTP2::ident_plain ) 121 | { 122 | $success |= 0b10; 123 | } 124 | } 125 | 126 | return undef unless $success == 0b11; 127 | 128 | return $end_headers_pos; 129 | } 130 | 131 | 1; 132 | -------------------------------------------------------------------------------- /minil.toml: -------------------------------------------------------------------------------- 1 | name = "Protocol-HTTP2" 2 | module_maker="ModuleBuildTiny" 3 | # badges = ["travis"] 4 | -------------------------------------------------------------------------------- /t/00_compile.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | 4 | use_ok $_ for qw( 5 | Protocol::HTTP2 6 | ); 7 | 8 | done_testing; 9 | 10 | -------------------------------------------------------------------------------- /t/01_HeaderCompression.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use lib 't/lib'; 5 | use PH2Test; 6 | use Protocol::HTTP2::Connection; 7 | use Protocol::HTTP2::Constants qw(:endpoints :limits :settings); 8 | 9 | BEGIN { 10 | use_ok( 'Protocol::HTTP2::HeaderCompression', 11 | qw(int_encode int_decode str_encode str_decode headers_decode headers_encode) 12 | ); 13 | } 14 | 15 | subtest 'int_encode' => sub { 16 | ok binary_eq( int_encode( 0, 8 ), pack( "C", 0 ) ); 17 | ok binary_eq( int_encode( 0xFD, 8 ), pack( "C", 0xFD ) ); 18 | ok binary_eq( int_encode( 0xFF, 8 ), pack( "C*", 0xFF, 0x00 ) ); 19 | ok binary_eq( int_encode( 0x100, 8 ), pack( "C*", 0xFF, 0x01 ) ); 20 | ok binary_eq( int_encode( 1337, 5 ), pack( "C*", 31, 154, 10 ) ); 21 | }; 22 | 23 | subtest 'int_decode' => sub { 24 | my $buf = pack( "C*", 31, 154, 10 ); 25 | my $int = 0; 26 | is int_decode( \$buf, 0, \$int, 5 ), 3; 27 | is $int, 1337; 28 | }; 29 | 30 | subtest 'str_encode' => sub { 31 | 32 | ok binary_eq( str_encode('//ee'), hstr("8361 8297") ); 33 | 34 | }; 35 | 36 | subtest 'str_decode' => sub { 37 | my $s = hstr(< sub { 46 | 47 | my $con = Protocol::HTTP2::Connection->new(CLIENT); 48 | my $ctx = $con->encode_context; 49 | 50 | ok binary_eq( 51 | headers_encode( 52 | $ctx, 53 | [ 54 | ':method' => 'GET', 55 | ':scheme' => 'http', 56 | ':path' => '/', 57 | ':authority' => 'www.example.com', 58 | ] 59 | ), 60 | hstr(< 'GET', 70 | ':scheme' => 'http', 71 | ':path' => '/', 72 | ':authority' => 'www.example.com', 73 | 'cache-control' => 'no-cache', 74 | ] 75 | ), 76 | hstr(< 'GET', 85 | ':scheme' => 'https', 86 | ':path' => '/index.html', 87 | ':authority' => 'www.example.com', 88 | 'custom-key' => 'custom-value', 89 | ] 90 | ), 91 | hstr(< sub { 99 | 100 | my $con = Protocol::HTTP2::Connection->new(SERVER); 101 | my $ctx = $con->encode_context; 102 | $ctx->{max_ht_size} = $ctx->{settings}->{&SETTINGS_HEADER_TABLE_SIZE} = 256; 103 | 104 | ok binary_eq( 105 | headers_encode( 106 | $ctx, 107 | [ 108 | ':status' => '302', 109 | 'cache-control' => 'private', 110 | 'date' => 'Mon, 21 Oct 2013 20:13:21 GMT', 111 | 'location' => 'https://www.example.com', 112 | ] 113 | ), 114 | hstr(<{ht_size} => 222, 'ht_size ok'; 122 | 123 | ok binary_eq( 124 | headers_encode( 125 | $ctx, 126 | [ 127 | ':status' => 307, 128 | 'cache-control' => 'private', 129 | 'date' => 'Mon, 21 Oct 2013 20:13:21 GMT', 130 | 'location' => 'https://www.example.com', 131 | ] 132 | ), 133 | hstr("4803 3330 37c1 c0bf") 134 | ); 135 | 136 | is $ctx->{ht_size} => 222, 'ht_size ok'; 137 | 138 | ok binary_eq( 139 | headers_encode( 140 | $ctx, 141 | [ 142 | ':status' => 200, 143 | 'cache-control' => 'private', 144 | 'date' => 'Mon, 21 Oct 2013 20:13:22 GMT', 145 | 'location' => 'https://www.example.com', 146 | 'content-encoding' => 'gzip', 147 | 'set-cookie' => 148 | 'foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1', 149 | ] 150 | ), 151 | hstr(<{ht_size} => 215, 'ht_size ok'; 159 | 160 | }; 161 | 162 | subtest 'decode requests' => sub { 163 | 164 | my $con = Protocol::HTTP2::Connection->new(SERVER); 165 | my $ctx = $con->decode_context; 166 | 167 | my $buf = hstr(<{emitted_headers}, 175 | [ 176 | ':method' => 'GET', 177 | ':scheme' => 'http', 178 | ':path' => '/', 179 | ':authority' => 'www.example.com' 180 | ], 181 | "emitted headers"; 182 | $ctx->{emitted_headers} = []; 183 | is_deeply $ctx->{header_table}, [ [ ':authority' => 'www.example.com' ] ], 184 | "dynamic table"; 185 | is $ctx->{ht_size}, 57, "correct table size"; 186 | 187 | $buf = hstr('8286 84be 5886 a8eb 1064 9cbf'); 188 | is headers_decode( $con, \$buf, 0, length $buf ), length($buf), 189 | "correct offset"; 190 | is_deeply $ctx->{emitted_headers}, 191 | [ 192 | ':method' => 'GET', 193 | ':scheme' => 'http', 194 | ':path' => '/', 195 | ':authority' => 'www.example.com', 196 | 'cache-control' => 'no-cache', 197 | ], 198 | "emitted headers"; 199 | $ctx->{emitted_headers} = []; 200 | is_deeply $ctx->{header_table}, [ 201 | [ 'cache-control' => 'no-cache' ], 202 | 203 | [ ':authority' => 'www.example.com' ] 204 | ], 205 | "dynamic table"; 206 | is $ctx->{ht_size}, 110, "correct table size"; 207 | 208 | $buf = hstr(<{emitted_headers}, 215 | [ 216 | ':method' => 'GET', 217 | ':scheme' => 'https', 218 | ':path' => '/index.html', 219 | ':authority' => 'www.example.com', 220 | 'custom-key' => 'custom-value', 221 | ], 222 | "emitted headers"; 223 | is_deeply $ctx->{header_table}, [ 224 | [ 'custom-key' => 'custom-value' ], 225 | [ 226 | 'cache-control' => 'no-cache' 227 | ], 228 | 229 | [ ':authority' => 'www.example.com' ] 230 | ], 231 | "dynamic table"; 232 | is $ctx->{ht_size}, 164, "correct table size"; 233 | 234 | }; 235 | 236 | done_testing(); 237 | __END__ 238 | 239 | 240 | subtest 'decode responses' => sub { 241 | my $decoder = Protocol::HTTP2::HeaderCompression->new; 242 | 243 | $decoder->{_max_ht_size} = 256; 244 | 245 | is $decoder->headers_decode( \hstr(< '302' ], 254 | [ 'cache-control' => 'private' ], 255 | [ 'date' => 'Mon, 21 Oct 2013 20:13:21 GMT' ], 256 | [ 'location' => 'https://www.example.com' ], 257 | 258 | ] or diag explain \@headers; 259 | 260 | @headers = (); 261 | 262 | is $decoder->headers_decode( \hstr("8c"), \@headers ), 1; 263 | 264 | is_deeply \@headers, [ [ ':status' => '200' ], ] or diag explain \@headers; 265 | 266 | @headers = (); 267 | 268 | is $decoder->headers_decode( \hstr(< 'private' ], 280 | [ 'date' => 'Mon, 21 Oct 2013 20:13:22 GMT' ], 281 | [ 'content-encoding' => 'gzip' ], 282 | [ 'location' => 'https://www.example.com' ], 283 | [ ':status' => '200' ], 284 | [ 285 | 'set-cookie' => 286 | 'foo=ASDJKHQKBZXOQWEOPIUAXQWEOIU; max-age=3600; version=1' 287 | ], 288 | ] 289 | or diag explain \@headers; 290 | 291 | }; 292 | 293 | done_testing; 294 | 295 | -------------------------------------------------------------------------------- /t/02_Huffman.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Data::Dumper; 5 | BEGIN { use_ok('Protocol::HTTP2::Huffman') } 6 | 7 | use lib 't/lib'; 8 | use PH2Test; 9 | 10 | my $example = "www.example.com"; 11 | my $s = huffman_encode($example); 12 | 13 | ok binary_eq( $s, hstr("f1e3 c2e5 f23a 6ba0 ab90 f4ff") ), "encode"; 14 | is huffman_decode($s), $example, "decode"; 15 | 16 | done_testing(); 17 | -------------------------------------------------------------------------------- /t/03_connection.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Protocol::HTTP2::Constants qw(const_name :endpoints :states); 5 | use lib 't/lib'; 6 | use PH2Test; 7 | 8 | BEGIN { 9 | use_ok('Protocol::HTTP2::Connection'); 10 | } 11 | 12 | done_testing(); 13 | __END__ 14 | 15 | subtest 'decode_request' => sub { 16 | 17 | my $data = hstr(<new( SERVER, 29 | on_change_state => sub { 30 | my ( $stream_id, $previous_state, $current_state ) = @_; 31 | printf "Stream %i changed state from %s to %s\n", 32 | $stream_id, const_name( "states", $previous_state ), 33 | const_name( "states", $current_state ); 34 | 35 | if ( $current_state == HALF_CLOSED ) { 36 | $run_test->($stream_id); 37 | } 38 | }, 39 | on_error => sub { 40 | fail("Error occurred"); 41 | } 42 | ); 43 | 44 | my $run_test_flag = 0; 45 | 46 | $run_test = sub { 47 | my $stream_id = shift; 48 | is_deeply( 49 | $con->stream_headers($stream_id), 50 | [ 51 | ':authority' => '127.0.0.1:8000', 52 | ':method' => 'GET', 53 | ':path' => '/LICENSE', 54 | ':scheme' => 'http', 55 | 'accept' => '*/*', 56 | 'accept-encoding' => 'gzip, deflate', 57 | 'user-agent' => 'nghttp2/0.4.0-DEV', 58 | ], 59 | "correct request headers" 60 | ) and $run_test_flag = 1; 61 | }; 62 | 63 | my $offset = $con->preface_decode( \$data, 0 ); 64 | is( $offset, 24, "Preface exists" ) or BAIL_OUT "preface?"; 65 | while ( my $size = $con->frame_decode( \$data, $offset ) ) { 66 | $offset += $size; 67 | } 68 | ok( $con->error == 0 && $run_test_flag, "decode headers" ); 69 | $data = hstr("0000 0401 0000 0000"); 70 | $offset = 0; 71 | while ( my $size = $con->frame_decode( \$data, $offset ) ) { 72 | $offset += $size; 73 | } 74 | ok( $con->error == 0 ); 75 | 76 | $data = hstr("0008 0700 0000 0000 0000 0000 0000 0000"); 77 | $offset = 0; 78 | while ( my $size = $con->frame_decode( \$data, $offset ) ) { 79 | $offset += $size; 80 | } 81 | ok( $con->error == 0 ); 82 | }; 83 | 84 | subtest 'decode_response' => sub { 85 | 86 | my $data = hstr(<new(CLIENT); 91 | 92 | # Emulate request 93 | my $sid = $con->new_stream; 94 | $con->stream_state( $sid, HALF_CLOSED ); 95 | 96 | my $run_test_flag = 0; 97 | $con->stream_cb( 98 | $sid, CLOSED, 99 | sub { 100 | 101 | is_deeply( 102 | $con->stream_headers($sid), 103 | [ 104 | ':status' => 200, 105 | 'server' => 'nghttpd nghttp2/0.4.0-DEV', 106 | 'content-length' => 46, 107 | 'cache-control' => 'max-age=3600', 108 | 'date' => 'Fri, 18 Apr 2014 07:27:11 GMT', 109 | 'last-modified' => 'Thu, 27 Feb 2014 10:30:37 GMT', 110 | ], 111 | "correct response headers" 112 | ) and $run_test_flag = 1; 113 | } 114 | ); 115 | 116 | my $offset = 0; 117 | while ( my $size = $con->frame_decode( \$data, $offset ) ) { 118 | $offset += $size; 119 | } 120 | ok( $con->error == 0 ); 121 | 122 | $data = hstr(<frame_decode( \$data, $offset ) ) { 137 | $offset += $size; 138 | } 139 | is $offset, length($data), "read all data"; 140 | ok( $con->error == 0 && $run_test_flag ); 141 | 142 | }; 143 | 144 | done_testing(); 145 | -------------------------------------------------------------------------------- /t/04_continuation.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Protocol::HTTP2::Constants qw(const_name :endpoints :states); 5 | 6 | BEGIN { 7 | use_ok('Protocol::HTTP2::Connection'); 8 | } 9 | 10 | done_testing; 11 | __END__ 12 | subtest 'decode_continuation_request' => sub { 13 | 14 | open my $fh, '<:raw', 't/continuation.request.data' or die $!; 15 | my $data = do { local $/; <$fh> }; 16 | 17 | my $con = Protocol::HTTP2::Connection->new( SERVER, 18 | on_change_state => sub { 19 | my ( $stream_id, $previous_state, $current_state ) = @_; 20 | printf "Stream %i changed state from %s to %s\n", 21 | $stream_id, const_name( "states", $previous_state ), 22 | const_name( "states", $current_state ); 23 | }, 24 | on_error => sub { 25 | fail("Error occurred"); 26 | } 27 | ); 28 | my $offset = $con->preface_decode( \$data, 0 ); 29 | is( $offset, 24, "Preface exists" ) or BAIL_OUT "preface?"; 30 | while ( my $size = $con->frame_decode( \$data, $offset ) ) { 31 | $offset += $size; 32 | } 33 | is $con->error, 0, "no errors"; 34 | }; 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /t/05_trace.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | BEGIN { 6 | use_ok( 'Protocol::HTTP2::Trace', qw(tracer bin2hex) ); 7 | } 8 | 9 | subtest 'bin2hex' => sub { 10 | is bin2hex("ABCDEFGHIJKLMNOPQR"), 11 | "4142 4344 4546 4748 494a 4b4c 4d4e 4f50\n5152 "; 12 | }; 13 | 14 | done_testing; 15 | 16 | -------------------------------------------------------------------------------- /t/06_upgrade.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Protocol::HTTP2::Constants qw(const_name :endpoints :states); 5 | 6 | BEGIN { 7 | use_ok('Protocol::HTTP2::Connection'); 8 | } 9 | 10 | subtest 'decode_upgrade_response' => sub { 11 | 12 | my $con = Protocol::HTTP2::Connection->new(CLIENT); 13 | 14 | my $buf = join "\x0d\x0a", 15 | "\x00HTTP/1.1 101 Switching Protocols", 16 | "Connection: Upgrade", 17 | "SomeHeader: bla bla", 18 | "Upgrade: h2c", "", 19 | "here is some binary data"; 20 | is $con->decode_upgrade_response( \$buf, 1 ), 92, "correct pos"; 21 | 22 | $buf =~ s/101/200/; 23 | is $con->decode_upgrade_response( \$buf, 1 ), undef, "no switch"; 24 | $buf =~ s/200/101/; 25 | 26 | $buf =~ s/h2c/xyz/; 27 | is $con->decode_upgrade_response( \$buf, 1 ), undef, 28 | "wrong Upgrade protocol"; 29 | $buf =~ s/xyz/h2c/; 30 | 31 | is $con->decode_upgrade_response( \substr( $buf, 0, 80 ), 1 ), 0, 32 | "wait another portion of data\n"; 33 | }; 34 | 35 | subtest 'decode_upgrade_request' => sub { 36 | 37 | my $con = Protocol::HTTP2::Connection->new(SERVER); 38 | 39 | my $buf = join "\x0d\x0a", 40 | "\x00GET /default.htm HTTP/1.1", 41 | "Host: server.example.com", 42 | "Connection: Upgrade, HTTP2-Settings", 43 | "Upgrade: h2c", 44 | "HTTP2-Settings: AAAABAAAAAAA", 45 | "User-Agent: perl-Protocol-HTTP2/0.10", 46 | "", ""; 47 | 48 | is $con->decode_upgrade_request( \$buf, 1 ), length($buf) - 1, 49 | "correct pos"; 50 | 51 | }; 52 | 53 | done_testing; 54 | -------------------------------------------------------------------------------- /t/07_ping.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use lib 't/lib'; 5 | use PH2Test; 6 | use Protocol::HTTP2::Constants qw(const_name :frame_types :endpoints :states 7 | :flags); 8 | use Protocol::HTTP2::Connection; 9 | use Protocol::HTTP2::Client; 10 | use Protocol::HTTP2::Server; 11 | 12 | subtest 'ping' => sub { 13 | 14 | my $client = Protocol::HTTP2::Client->new; 15 | $client->request( 16 | ':authority' => 'localhost', 17 | ':method' => 'GET', 18 | ':path' => '/', 19 | ':scheme' => 'https', 20 | ); 21 | 22 | my $server = Protocol::HTTP2::Server->new; 23 | 24 | while ( my $frame = $client->next_frame ) { 25 | $server->feed($frame); 26 | while ( $frame = $server->next_frame ) { 27 | $client->feed($frame); 28 | } 29 | } 30 | 31 | $client->ping("HELLOSRV"); 32 | my $ping = $client->next_frame; 33 | ok binary_eq( $ping, hstr("0000 0806 0000 0000 0048 454c 4c4f 5352 56") ), 34 | "ping"; 35 | $server->feed($ping); 36 | ok binary_eq( $ping = $server->next_frame, 37 | hstr("0000 0806 0100 0000 0048 454c 4c4f 5352 56") ), 38 | "ping ack"; 39 | is $server->next_frame, undef; 40 | $client->feed($ping); 41 | is $client->next_frame, undef; 42 | }; 43 | 44 | subtest 'dont mess with continuation' => sub { 45 | my $con = Protocol::HTTP2::Connection->new(CLIENT); 46 | $con->preface(1); 47 | 48 | $con->new_stream(1); 49 | my @hdrs = ( HEADERS, 0, 1, { hblock => \"\x82" } ); 50 | my @cont = ( CONTINUATION, END_HEADERS, 1, \"\x85" ); 51 | my @data = ( DATA, 0, 1, \"DATA" ); 52 | 53 | $con->enqueue( @hdrs, @cont, @data ); 54 | 55 | ok binary_eq( $con->dequeue, $con->frame_encode(@hdrs) ), "1-HEADER"; 56 | 57 | my @ping = ( PING, 0, 0, \"HELLOSRV" ); 58 | $con->enqueue_first(@ping); 59 | 60 | ok binary_eq( $con->dequeue, $con->frame_encode(@cont) ), "2-CONTINUATION"; 61 | ok binary_eq( $con->dequeue, $con->frame_encode(@ping) ), "3-PING"; 62 | ok binary_eq( $con->dequeue, $con->frame_encode(@data) ), "4-DATA"; 63 | }; 64 | 65 | done_testing 66 | -------------------------------------------------------------------------------- /t/08_priority.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use lib 't/lib'; 5 | use PH2Test; 6 | use Protocol::HTTP2::Constants qw(const_name :frame_types :endpoints :states 7 | :flags); 8 | use Protocol::HTTP2::Connection; 9 | 10 | subtest 'priority frame' => sub { 11 | 12 | my $con = Protocol::HTTP2::Connection->new(SERVER); 13 | 14 | my $frame = $con->frame_encode( PRIORITY, 0, 1, [ 0, 32 ] ); 15 | ok binary_eq( $frame, hstr("0000 0502 0000 0000 0100 0000 001f") ), 16 | "PRIORITY"; 17 | 18 | # Simulate client request 19 | $con->preface(1); 20 | $con->new_peer_stream(1); 21 | 22 | my $res = $con->frame_decode( \$frame, 0 ); 23 | is $res, 14, "decoded correctly"; 24 | 25 | $frame = $con->frame_encode( HEADERS, 26 | END_HEADERS, 27 | 1, 28 | { 29 | hblock => \hstr("41 8aa0 e41d 139d 09b8 f000 0f82 8486"), 30 | stream_dep => 0, 31 | weight => 32 32 | } 33 | ); 34 | 35 | ok binary_eq( 36 | $frame, 37 | hstr( 38 | "0000 1401 2400 0000 0100 0000 001f 418a" 39 | . "a0e4 1d13 9d09 b8f0 000f 8284 86" 40 | ) 41 | ), 42 | "Headers with priority"; 43 | 44 | $res = $con->frame_decode( \$frame, 0 ); 45 | is $res, 29, "decoded correctly"; 46 | }; 47 | 48 | subtest 'stream reprioritization' => sub { 49 | 50 | my $con = Protocol::HTTP2::Connection->new(SERVER); 51 | 52 | # Simulate client request 53 | $con->preface(1); 54 | $con->new_peer_stream(1); 55 | $con->new_peer_stream(3); 56 | $con->new_peer_stream(5); 57 | 58 | # 0 59 | # /|\ 60 | # 1 3 5 61 | 62 | ok $con->stream_reprio( 1, 1, 0 ), "stream_reprio exclusive 1 done"; 63 | 64 | # 1 65 | # / \ 66 | # 3 5 67 | 68 | is $con->stream(1)->{stream_dep}, 0, "1 on top"; 69 | is $con->stream(3)->{stream_dep}, 1, "3 under 1"; 70 | is $con->stream(5)->{stream_dep}, 1, "5 under 1"; 71 | 72 | $con->new_peer_stream(7); 73 | ok $con->stream_reprio( 7, 0, 1 ), "stream_reprio 7"; 74 | $con->new_peer_stream(9); 75 | ok $con->stream_reprio( 9, 0, 7 ), "stream_reprio 9"; 76 | $con->new_peer_stream(11); 77 | ok $con->stream_reprio( 11, 0, 9 ), "stream_reprio 11"; 78 | 79 | ok $con->stream_reprio( 1, 0, 9 ), "stream_reprio 1 under 9"; 80 | 81 | # 82 | # 1 9 83 | # / | \ / \ 84 | # 3 5 7 11 1 85 | # \ => / | \ 86 | # 9 3 5 7 87 | # \ 88 | # 11 89 | 90 | is $con->stream(9)->{stream_dep}, 0, "9 on top"; 91 | is $con->stream(11)->{stream_dep}, 9, "11 under 9"; 92 | is $con->stream(1)->{stream_dep}, 9, "1 under 9"; 93 | is $con->stream(3)->{stream_dep}, 1, "3 under 1"; 94 | is $con->stream(5)->{stream_dep}, 1, "3 under 1"; 95 | is $con->stream(7)->{stream_dep}, 1, "7 under 1"; 96 | 97 | #diag explain $con->{streams}; 98 | }; 99 | 100 | done_testing; 101 | -------------------------------------------------------------------------------- /t/09_client_server_tcp.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use lib 't/lib'; 5 | use PH2ClientServerTest; 6 | use Test::TCP; 7 | use Protocol::HTTP2; 8 | 9 | my $host = '127.0.0.1'; 10 | 11 | subtest 'client/server' => sub { 12 | for my $opts ( 13 | [ "without tls", [], [] ], 14 | [ "without tls, upgrade", [ upgrade => 1 ], [ upgrade => 1 ] ], 15 | [ 16 | "tls/npn", 17 | [ npn => 1 ], 18 | [ 19 | npn => 1, 20 | tls_crt => 'examples/test.crt', 21 | tls_key => 'examples/test.key' 22 | ] 23 | ], 24 | [ 25 | "tls/alpn", 26 | [ alpn => 1 ], 27 | [ 28 | alpn => 1, 29 | tls_crt => 'examples/test.crt', 30 | tls_key => 'examples/test.key' 31 | ] 32 | ], 33 | ) 34 | { 35 | my $test = shift @$opts; 36 | note "test: $test\n"; 37 | 38 | # Check for NPN/ALPN 39 | if ( !check_tls( @{ $opts->[0] } ) ) { 40 | note "skipped $test: feature not available\n"; 41 | next; 42 | } 43 | 44 | eval { 45 | local $SIG{ALRM} = sub { die "timeout\n" }; 46 | alarm 16; 47 | test_tcp( 48 | client => sub { 49 | my $port = shift; 50 | client( 51 | @{ $opts->[0] }, 52 | port => $port, 53 | host => $host, 54 | on_error => sub { 55 | fail "error occurred: " . shift; 56 | }, 57 | test_cb => sub { 58 | my $client = shift; 59 | $client->request( 60 | ':scheme' => "http", 61 | ':authority' => $host . ":" . $port, 62 | ':path' => "/", 63 | ':method' => "GET", 64 | headers => [ 65 | 'accept' => '*/*', 66 | 'user-agent' => 'perl-Protocol-HTTP2/' 67 | . $Protocol::HTTP2::VERSION, 68 | ], 69 | on_done => sub { 70 | my ( $headers, $data ) = @_; 71 | is scalar(@$headers) / 2, 6, 72 | "get response headers"; 73 | is length($data), 13, "get body"; 74 | }, 75 | ); 76 | } 77 | ); 78 | }, 79 | server => sub { 80 | my $port = shift; 81 | my $server; 82 | server( 83 | @{ $opts->[1] }, 84 | port => $port, 85 | host => $host, 86 | on_error => sub { 87 | fail "error occurred: " . shift; 88 | }, 89 | test_cb => sub { 90 | $server = shift; 91 | }, 92 | on_request => sub { 93 | my ( $stream_id, $headers, $data ) = @_; 94 | my $message = "hello, world!"; 95 | $server->response( 96 | ':status' => 200, 97 | stream_id => $stream_id, 98 | headers => [ 99 | 'server' => 'perl-Protocol-HTTP2/' 100 | . $Protocol::HTTP2::VERSION, 101 | 'content-length' => length($message), 102 | 'cache-control' => 'max-age=3600', 103 | 'date' => 'Fri, 18 Apr 2014 07:27:11 GMT', 104 | 'last-modified' => 105 | 'Thu, 27 Feb 2014 10:30:37 GMT', 106 | ], 107 | data => $message, 108 | ); 109 | }, 110 | ); 111 | }, 112 | ); 113 | alarm 0; 114 | }; 115 | is $@, '', "no errors"; 116 | } 117 | }; 118 | 119 | done_testing; 120 | -------------------------------------------------------------------------------- /t/10_settings.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use lib 't/lib'; 5 | use PH2Test; 6 | use Protocol::HTTP2::Constants qw(:settings); 7 | use Protocol::HTTP2::Client; 8 | use Protocol::HTTP2::Server; 9 | 10 | subtest 'client settings' => sub { 11 | 12 | my $c = 13 | Protocol::HTTP2::Client->new( 14 | settings => { &SETTINGS_HEADER_TABLE_SIZE => 100 } ); 15 | $c->request( 16 | ':scheme' => 'http', 17 | ':authority' => 'localhost:8000', 18 | ':path' => '/', 19 | ':method' => 'GET', 20 | ); 21 | 22 | # PRI 23 | $c->next_frame; 24 | 25 | # SETTINGS 26 | ok binary_eq( hstr('0000 0604 0000 0000 0000 0100 0000 64'), 27 | $c->next_frame ), 28 | "send only changed from default values settings"; 29 | }; 30 | 31 | subtest 'server settings' => sub { 32 | 33 | my $s = Protocol::HTTP2::Server->new; 34 | 35 | ok binary_eq( hstr('0000 0604 0000 0000 0000 0300 0000 64'), 36 | $s->next_frame ), "server defaults not empty"; 37 | }; 38 | 39 | done_testing; 40 | -------------------------------------------------------------------------------- /t/11_server_stream.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Protocol::HTTP2::Client; 5 | use Protocol::HTTP2::Server; 6 | use lib 't/lib'; 7 | use PH2Test qw(fake_connect); 8 | 9 | subtest 'server stream' => sub { 10 | 11 | my $server; 12 | $server = Protocol::HTTP2::Server->new( 13 | on_request => sub { 14 | my ( $stream_id, $headers, $data ) = @_; 15 | 16 | my $s_stream = $server->response_stream( 17 | ':status' => 200, 18 | stream_id => $stream_id, 19 | 20 | # HTTP/1.1 Headers 21 | headers => [ 22 | 'server' => 'perl-Protocol-HTTP2/0.16', 23 | 'cache-control' => 'max-age=3600', 24 | 'date' => 'Fri, 18 Apr 2014 07:27:11 GMT', 25 | 'last-modified' => 'Thu, 27 Feb 2014 10:30:37 GMT', 26 | ], 27 | ); 28 | 29 | isa_ok( $s_stream, 'Protocol::HTTP2::Server::Stream' ); 30 | $s_stream->send('a'); 31 | $s_stream->send('b'); 32 | $s_stream->close; 33 | }, 34 | ); 35 | 36 | my $client = Protocol::HTTP2::Client->new; 37 | $client->request( 38 | 39 | # HTTP/2 headers 40 | ':scheme' => 'http', 41 | ':authority' => 'localhost:8000', 42 | ':path' => '/', 43 | ':method' => 'GET', 44 | 45 | # HTTP/1.1 headers 46 | headers => [ 47 | 'accept' => '*/*', 48 | 'user-agent' => 'perl-Protocol-HTTP2/0.16', 49 | ], 50 | 51 | # Callback when receive server's response 52 | on_done => sub { 53 | my ( $headers, $data ) = @_; 54 | is $data, "ab", "stream data ok"; 55 | }, 56 | ); 57 | 58 | fake_connect( $server, $client ); 59 | }; 60 | 61 | subtest 'client cancel' => sub { 62 | 63 | my $cancel = 0; 64 | my $s_stream; 65 | my $server; 66 | $server = Protocol::HTTP2::Server->new( 67 | on_request => sub { 68 | my ( $stream_id, $headers, $data ) = @_; 69 | 70 | $s_stream = $server->response_stream( 71 | ':status' => 200, 72 | stream_id => $stream_id, 73 | 74 | # HTTP/1.1 Headers 75 | headers => [ 'server' => 'perl-Protocol-HTTP2/0.16', ], 76 | on_cancel => sub { 77 | $cancel = 1; 78 | } 79 | ); 80 | 81 | isa_ok( $s_stream, 'Protocol::HTTP2::Server::Stream' ); 82 | $s_stream->send('a'); 83 | }, 84 | ); 85 | 86 | my $client = Protocol::HTTP2::Client->new; 87 | $client->request( 88 | 89 | # HTTP/2 headers 90 | ':scheme' => 'http', 91 | ':authority' => 'localhost:8000', 92 | ':path' => '/', 93 | ':method' => 'GET', 94 | 95 | # HTTP/1.1 headers 96 | headers => [ 'user-agent' => 'perl-Protocol-HTTP2/0.16', ], 97 | 98 | on_headers => sub { 99 | is_deeply $_[0], 100 | [ ':status' => 200, 'server' => 'perl-Protocol-HTTP2/0.16' ], 101 | "correct headers"; 102 | 1; 103 | }, 104 | 105 | # Callback when receive server's response 106 | on_data => sub { 107 | my ( $chunk, $headers ) = @_; 108 | is $chunk, "a", "stream data ok"; 109 | 110 | # cancel 111 | 0; 112 | }, 113 | ); 114 | 115 | fake_connect( $server, $client ); 116 | is $cancel, 1, "successfully canceled"; 117 | }; 118 | 119 | done_testing; 120 | -------------------------------------------------------------------------------- /t/12_leaks.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Protocol::HTTP2::Client; 5 | use Protocol::HTTP2::Server; 6 | use Test::LeakTrace; 7 | 8 | sub fake_connect { 9 | my ( $server, $client ) = @_; 10 | 11 | my ( $clt_frame, $srv_frame ); 12 | do { 13 | $clt_frame = $client->next_frame; 14 | $srv_frame = $server->next_frame; 15 | $server->feed($clt_frame) if $clt_frame; 16 | $client->feed($srv_frame) if $srv_frame; 17 | } while ( $clt_frame || $srv_frame ); 18 | } 19 | 20 | no_leaks_ok { 21 | my $server; 22 | $server = Protocol::HTTP2::Server->new( 23 | on_request => sub { 24 | $server; 25 | } 26 | ); 27 | undef $server; 28 | }; 29 | 30 | no_leaks_ok { 31 | my $server; 32 | $server = Protocol::HTTP2::Server->new( 33 | on_request => sub { 34 | my ( $stream_id, $headers, $data ) = @_; 35 | 36 | my $s_stream = $server->response_stream( 37 | ':status' => 200, 38 | stream_id => $stream_id, 39 | 40 | # HTTP/1.1 Headers 41 | headers => [ 42 | 'server' => 'perl-Protocol-HTTP2/0.16', 43 | 'cache-control' => 'max-age=3600', 44 | 'date' => 'Fri, 18 Apr 2014 07:27:11 GMT', 45 | 'last-modified' => 'Thu, 27 Feb 2014 10:30:37 GMT', 46 | ], 47 | ); 48 | 49 | $s_stream->send('a'); 50 | $s_stream->send('b'); 51 | $s_stream->close; 52 | }, 53 | ); 54 | 55 | my $client = Protocol::HTTP2::Client->new; 56 | $client->request( 57 | 58 | # HTTP/2 headers 59 | ':scheme' => 'http', 60 | ':authority' => 'localhost:8000', 61 | ':path' => '/', 62 | ':method' => 'GET', 63 | 64 | # HTTP/1.1 headers 65 | headers => [ 66 | 'accept' => '*/*', 67 | 'user-agent' => 'perl-Protocol-HTTP2/0.16', 68 | ], 69 | 70 | # Callback when receive server's response 71 | on_done => sub { 72 | my ( $headers, $data ) = @_; 73 | }, 74 | ); 75 | 76 | fake_connect( $server, $client ); 77 | 78 | undef $client; 79 | undef $server; 80 | }; 81 | 82 | no_leaks_ok { 83 | my $cancel = 0; 84 | my $s_stream; 85 | my $server; 86 | $server = Protocol::HTTP2::Server->new( 87 | on_request => sub { 88 | my ( $stream_id, $headers, $data ) = @_; 89 | 90 | $s_stream = $server->response_stream( 91 | ':status' => 200, 92 | stream_id => $stream_id, 93 | 94 | # HTTP/1.1 Headers 95 | headers => [ 'server' => 'perl-Protocol-HTTP2/0.16', ], 96 | on_cancel => sub { 97 | $cancel = 1; 98 | } 99 | ); 100 | 101 | $s_stream->send('a'); 102 | }, 103 | ); 104 | 105 | my $client = Protocol::HTTP2::Client->new; 106 | $client->request( 107 | 108 | # HTTP/2 headers 109 | ':scheme' => 'http', 110 | ':authority' => 'localhost:8000', 111 | ':path' => '/', 112 | ':method' => 'GET', 113 | 114 | # HTTP/1.1 headers 115 | headers => [ 'user-agent' => 'perl-Protocol-HTTP2/0.16', ], 116 | on_headers => sub { 117 | 1; 118 | }, 119 | 120 | # Callback when receive server's response 121 | on_data => sub { 122 | my ( $chunk, $headers ) = @_; 123 | 124 | # cancel 125 | 0; 126 | }, 127 | ); 128 | 129 | fake_connect( $server, $client ); 130 | undef $client; 131 | undef $server; 132 | undef $s_stream; 133 | }; 134 | 135 | done_testing; 136 | -------------------------------------------------------------------------------- /t/13_request_with_body.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Protocol::HTTP2::Client; 5 | use Protocol::HTTP2::Server; 6 | use lib 't/lib'; 7 | use PH2Test qw(fake_connect); 8 | 9 | subtest 'client POST' => sub { 10 | 11 | plan tests => 6; 12 | 13 | my $body = "DATA" x 10_000; 14 | my $location = "https://www.example.com/"; 15 | my $on_done = sub { 16 | my ( $headers, $data ) = @_; 17 | my %h = (@$headers); 18 | is $h{location}, $location, "correct redirect"; 19 | }; 20 | my %common = ( 21 | ':scheme' => 'http', 22 | ':authority' => 'localhost:8000', 23 | ':path' => '/', 24 | headers => [], 25 | on_done => $on_done, 26 | ); 27 | 28 | my $server; 29 | $server = Protocol::HTTP2::Server->new( 30 | on_request => sub { 31 | my ( $stream_id, $headers, $data ) = @_; 32 | my %h = (@$headers); 33 | 34 | if ( $h{':method'} eq 'POST' ) { 35 | is $body, $data, 'received correct POST body'; 36 | } 37 | elsif ( $h{':method'} eq 'PUT' ) { 38 | is $body, $data, 'received correct PUT body'; 39 | } 40 | elsif ( $h{':method'} eq 'OPTIONS' ) { 41 | is $data, undef, 'no body for OPTIONS'; 42 | } 43 | $server->response_stream( 44 | ':status' => 302, 45 | stream_id => $stream_id, 46 | headers => [ 47 | location => $location 48 | ], 49 | ); 50 | 51 | }, 52 | ); 53 | 54 | my $client = Protocol::HTTP2::Client->new; 55 | $client->request( 56 | %common, 57 | ':method' => 'POST', 58 | data => $body, 59 | )->request( %common, ':method' => 'OPTIONS', )->request( 60 | %common, 61 | ':method' => 'PUT', 62 | data => $body, 63 | ); 64 | 65 | fake_connect( $server, $client ); 66 | }; 67 | 68 | done_testing; 69 | -------------------------------------------------------------------------------- /t/14_keepalive.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use Protocol::HTTP2::Client; 5 | use Protocol::HTTP2::Server; 6 | use Protocol::HTTP2::Constants qw(:errors); 7 | use lib 't/lib'; 8 | use PH2Test qw(fake_connect); 9 | 10 | my %common = ( 11 | ':scheme' => 'https', 12 | ':authority' => 'localhost:8000', 13 | ':path' => '/', 14 | ':method' => 'GET', 15 | headers => [], 16 | ); 17 | 18 | subtest 'sequential requests' => sub { 19 | 20 | my $tests = 10; 21 | plan tests => $tests; 22 | 23 | my $server; 24 | $server = Protocol::HTTP2::Server->new( 25 | on_request => sub { 26 | $server->response_stream( 27 | ':status' => 204, 28 | stream_id => shift, 29 | headers => [], 30 | ); 31 | }, 32 | ); 33 | 34 | my $client = Protocol::HTTP2::Client->new; 35 | 36 | my $req; 37 | $req = sub { 38 | return if --$tests < 0; 39 | pass "request $tests"; 40 | $client->request( %common, on_done => $req ); 41 | }; 42 | $req->(); 43 | 44 | fake_connect( $server, $client ); 45 | }; 46 | 47 | subtest 'client keepalive' => sub { 48 | 49 | my $tests = 10; 50 | plan tests => $tests + 2; 51 | 52 | my $server; 53 | $server = Protocol::HTTP2::Server->new( 54 | on_request => sub { 55 | $server->response_stream( 56 | ':status' => 204, 57 | stream_id => shift, 58 | headers => [], 59 | ); 60 | }, 61 | ); 62 | 63 | my $client = Protocol::HTTP2::Client->new->keepalive(1); 64 | 65 | for my $i ( 1 .. $tests ) { 66 | $client->request( 67 | %common, 68 | on_done => sub { 69 | pass "request $i"; 70 | }, 71 | ); 72 | fake_connect( $server, $client ); 73 | } 74 | 75 | $client->close; 76 | fake_connect( $server, $client ); 77 | 78 | eval { $client->request(%common); }; 79 | ok $@, "request failed after close"; 80 | like $@, qr/closed/, "connection closed"; 81 | }; 82 | 83 | subtest 'client no keepalive' => sub { 84 | 85 | plan tests => 2; 86 | 87 | my $server; 88 | $server = Protocol::HTTP2::Server->new( 89 | on_request => sub { 90 | $server->response_stream( 91 | ':status' => 204, 92 | stream_id => shift, 93 | headers => [], 94 | ); 95 | }, 96 | ); 97 | 98 | my $client = Protocol::HTTP2::Client->new( 99 | keepalive => 0, 100 | on_error => sub { 101 | is( shift, PROTOCOL_ERROR, "request failed" ); 102 | }, 103 | ); 104 | 105 | $client->request( 106 | %common, 107 | on_done => sub { 108 | pass "request complete"; 109 | }, 110 | ); 111 | fake_connect( $server, $client ); 112 | 113 | $client->request( 114 | %common, 115 | on_done => sub { 116 | fail "keepalive?"; 117 | } 118 | ); 119 | fake_connect( $server, $client ); 120 | }; 121 | 122 | done_testing; 123 | -------------------------------------------------------------------------------- /t/continuation.request.data: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vlet/p5-Protocol-HTTP2/a1e13d02cc9fb33875676877be7176ef491a8307/t/continuation.request.data -------------------------------------------------------------------------------- /t/lib/PH2ClientServerTest.pm: -------------------------------------------------------------------------------- 1 | package PH2ClientServerTest; 2 | use strict; 3 | use warnings; 4 | use AnyEvent; 5 | use AnyEvent::Socket; 6 | use AnyEvent::Handle; 7 | use Net::SSLeay; 8 | use AnyEvent::TLS; 9 | 10 | use Protocol::HTTP2; 11 | use Protocol::HTTP2::Client; 12 | use Protocol::HTTP2::Server; 13 | use Protocol::HTTP2::Constants qw(const_name); 14 | 15 | use Exporter qw(import); 16 | our @EXPORT = qw(client server check_tls); 17 | use Carp; 18 | 19 | sub check_tls { 20 | my (%opts) = @_; 21 | return 22 | exists $opts{npn} ? exists &Net::SSLeay::P_next_proto_negotiated 23 | : exists $opts{alpn} ? exists &Net::SSLeay::P_alpn_selected 24 | : 1; 25 | } 26 | 27 | sub server { 28 | my (%h) = @_; 29 | 30 | my $cb = delete $h{test_cb} or croak "no servers test_cb"; 31 | my $port = delete $h{port} or croak "no port available"; 32 | my $host = delete $h{host}; 33 | my $tls_crt = delete $h{"tls_crt"}; 34 | my $tls_key = delete $h{"tls_key"}; 35 | 36 | my $w = AnyEvent->condvar; 37 | 38 | tcp_server $host, $port, sub { 39 | my ( $fh, $host, $port ) = @_; 40 | my $handle; 41 | my $tls; 42 | 43 | if ( !$h{upgrade} && ( $h{npn} || $h{alpn} ) ) { 44 | eval { 45 | $tls = AnyEvent::TLS->new( 46 | cert_file => $tls_crt, 47 | key_file => $tls_key, 48 | ); 49 | 50 | if ( $h{npn} ) { 51 | 52 | # NPN (Net-SSLeay > 1.45, openssl >= 1.0.1) 53 | Net::SSLeay::CTX_set_next_protos_advertised_cb( $tls->ctx, 54 | [Protocol::HTTP2::ident_tls] ); 55 | } 56 | if ( $h{alpn} ) { 57 | 58 | # ALPN (Net-SSLeay > 1.55, openssl >= 1.0.2) 59 | Net::SSLeay::CTX_set_alpn_select_cb( $tls->ctx, 60 | [Protocol::HTTP2::ident_tls] ); 61 | } 62 | }; 63 | if ($@) { 64 | croak "Some problem with SSL CTX: $@" . Net::SSLeay::print_errs(); 65 | } 66 | } 67 | 68 | $handle = AnyEvent::Handle->new( 69 | fh => $fh, 70 | autocork => 1, 71 | defined $tls 72 | ? ( 73 | tls => "accept", 74 | tls_ctx => $tls 75 | ) 76 | : (), 77 | on_error => sub { 78 | $_[0]->destroy; 79 | print STDERR "connection error: $_[2]: $!\n"; 80 | }, 81 | on_eof => sub { 82 | $handle->destroy; 83 | } 84 | ); 85 | 86 | my $server = Protocol::HTTP2::Server->new(%h); 87 | $cb->($server); 88 | 89 | # First send settings to peer 90 | while ( my $frame = $server->next_frame ) { 91 | $handle->push_write($frame); 92 | } 93 | 94 | $handle->on_read( 95 | sub { 96 | my $handle = shift; 97 | 98 | $server->feed( $handle->{rbuf} ); 99 | 100 | $handle->{rbuf} = undef; 101 | while ( my $frame = $server->next_frame ) { 102 | $handle->push_write($frame); 103 | } 104 | $handle->push_shutdown if $server->shutdown; 105 | } 106 | ); 107 | }; 108 | my $res = $w->recv; 109 | croak("error occurred\n") unless $res; 110 | } 111 | 112 | sub client { 113 | my (%h) = @_; 114 | my $port = delete $h{port} or croak "no port available"; 115 | my $tls; 116 | 117 | my $host = delete $h{host}; 118 | 119 | if ( delete $h{upgrade} ) { 120 | $h{upgrade} = 1; 121 | } 122 | elsif ( $h{npn} || $h{alpn} ) { 123 | eval { 124 | $tls = AnyEvent::TLS->new(); 125 | 126 | if ( delete $h{npn} ) { 127 | 128 | # NPN (Net-SSLeay > 1.45, openssl >= 1.0.1) 129 | Net::SSLeay::CTX_set_next_proto_select_cb( $tls->ctx, 130 | [Protocol::HTTP2::ident_tls] ); 131 | } 132 | if ( delete $h{alpn} ) { 133 | 134 | # ALPN (Net-SSLeay > 1.55, openssl >= 1.0.2) 135 | Net::SSLeay::CTX_set_alpn_protos( $tls->ctx, 136 | [Protocol::HTTP2::ident_tls] ); 137 | } 138 | }; 139 | if ($@) { 140 | croak "Some problem with SSL CTX: $@\n"; 141 | } 142 | } 143 | 144 | my $cb = delete $h{test_cb} or croak "no clients test_cb"; 145 | 146 | my $client = Protocol::HTTP2::Client->new(%h); 147 | $cb->($client); 148 | 149 | my $w = AnyEvent->condvar; 150 | 151 | tcp_connect $host, $port, sub { 152 | my ($fh) = @_ or do { 153 | print "connection failed: $!\n"; 154 | $w->send(0); 155 | return; 156 | }; 157 | 158 | my $handle; 159 | $handle = AnyEvent::Handle->new( 160 | fh => $fh, 161 | defined $tls 162 | ? ( 163 | tls => "connect", 164 | tls_ctx => $tls, 165 | ) 166 | : (), 167 | autocork => 1, 168 | on_error => sub { 169 | $_[0]->destroy; 170 | print STDERR "connection error: $_[2]: $!\n"; 171 | $w->send(0); 172 | }, 173 | on_eof => sub { 174 | $handle->destroy; 175 | $w->send(1); 176 | } 177 | ); 178 | 179 | # First write preface to peer 180 | while ( my $frame = $client->next_frame ) { 181 | $handle->push_write($frame); 182 | } 183 | 184 | $handle->on_read( 185 | sub { 186 | my $handle = shift; 187 | 188 | $client->feed( $handle->{rbuf} ); 189 | 190 | $handle->{rbuf} = undef; 191 | while ( my $frame = $client->next_frame ) { 192 | $handle->push_write($frame); 193 | } 194 | $handle->push_shutdown if $client->shutdown; 195 | } 196 | ); 197 | }; 198 | 199 | my $res = $w->recv; 200 | croak("error occurred\n") unless $res; 201 | } 202 | 203 | 1; 204 | -------------------------------------------------------------------------------- /t/lib/PH2Test.pm: -------------------------------------------------------------------------------- 1 | package PH2Test; 2 | use strict; 3 | use warnings; 4 | use Protocol::HTTP2::Trace qw(bin2hex); 5 | use Exporter qw(import); 6 | our @EXPORT = qw(hstr binary_eq fake_connect); 7 | 8 | sub hstr { 9 | my $str = shift; 10 | $str =~ s/\#.*//g; 11 | $str =~ s/\s//g; 12 | my @a = ( $str =~ /../g ); 13 | return pack "C*", map { hex $_ } @a; 14 | } 15 | 16 | sub binary_eq { 17 | my ( $b1, $b2 ) = @_; 18 | if ( $b1 eq $b2 ) { 19 | return 1; 20 | } 21 | else { 22 | $b1 = bin2hex($b1); 23 | $b2 = bin2hex($b2); 24 | chomp $b1; 25 | chomp $b2; 26 | print "$b1\n not equal \n$b2 \n"; 27 | return 0; 28 | } 29 | } 30 | 31 | sub fake_connect { 32 | my ( $server, $client ) = @_; 33 | 34 | my ( $clt_frame, $srv_frame ); 35 | do { 36 | $clt_frame = $client->next_frame; 37 | $srv_frame = $server->next_frame; 38 | $server->feed($clt_frame) if $clt_frame; 39 | $client->feed($srv_frame) if $srv_frame; 40 | } while ( $clt_frame || $srv_frame ); 41 | } 42 | 43 | 1; 44 | --------------------------------------------------------------------------------