├── .gitignore ├── Changes ├── Kit.pm.PL ├── LICENSE ├── MANIFEST ├── MANIFEST.SKIP ├── META.json ├── META.yml ├── Makefile.PL ├── README ├── README.md ├── benchmarks ├── anyevent-http-server-multicore.pl ├── anyevent-http-server.pl ├── anyevent-httpd.pl ├── ev-raw.pl ├── node.js ├── psgi.pl ├── starman-multicore.sh ├── starman.sh ├── twiggy.sh └── twisted.py ├── bin └── simple-server ├── ex ├── hdl_ex.pl ├── ws_ex.pl └── ws_ex_delayed.pl ├── lib └── AnyEvent │ └── HTTP │ ├── Server.pm │ └── Server │ ├── Req.pm │ └── WS.pm ├── makeall.sh └── t ├── 00-load.t ├── 01-basic-ae.t ├── 02-basic-ev.t ├── 03-sendfile.t ├── basic.pl ├── pod.t └── testlib.pm /.gitignore: -------------------------------------------------------------------------------- 1 | blib* 2 | inc* 3 | MYMETA* 4 | Makefile 5 | Makefile.old 6 | MANIFEST.bak 7 | Build 8 | Build.bat 9 | _build* 10 | pm_to_blib* 11 | *.tar.gz 12 | .lwpcookies 13 | cover_db 14 | pod2htm*.tmp 15 | AnyEvent-HTTP-Server-* 16 | tmp/root* 17 | *debug.log* 18 | *.swp 19 | *.swo 20 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for AnyEvent-HTTP-Server 2 | 3 | TODO: more tests ;) 4 | TODO: more work on keepalive 5 | TODO: chunked requests 6 | TODO: WebSockets 7 | TODO: Dispatchers 8 | TODO: XS Enhancements 9 | TODO: send reply with content length and send body in chunks 10 | 11 | 1.9996 Apr 23 2016 12 | Fix websocket for on delayed request upgrade 13 | 14 | 1.9995 Nov 8 2015 15 | Fix "Complex regular subexpression recursion limit exceeded" 16 | 17 | 1.95 Jan 22 2013 18 | Complete rewrite ;) 19 | 20 | 0.01 May 2 2010 21 | First version, released on an unsuspecting world. 22 | 23 | -------------------------------------------------------------------------------- /Kit.pm.PL: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | 4 | BEGIN{ 5 | @ARGV or 6 | push @ARGV, do { my $x = $0; $x =~ s{\.PL$}{};$x }; 7 | } 8 | 9 | my $package = $ARGV[0]; 10 | for ($package) { 11 | s{^(?:blib/|)lib/}{}; 12 | s{\.pm$}{}; 13 | s{/}{::}sg; 14 | } 15 | 16 | 17 | open STDOUT, ">$ARGV[0]~" or die "$ARGV[0]~: $!"; 18 | 19 | 20 | our $WARNS; 21 | our $NOWARNS; 22 | our $HINTS; 23 | our %HINTS; 24 | 25 | BEGIN { 26 | $HINTS = $^H; 27 | $WARNS = ${^WARNING_BITS}; 28 | %HINTS = %^H; 29 | } 30 | 31 | use 5.008008; 32 | use strict; 33 | 34 | no warnings; 35 | BEGIN { 36 | $NOWARNS = ${^WARNING_BITS}; 37 | } 38 | 39 | use warnings qw(FATAL closed threads internal debugging pack substr malloc 40 | unopened portable prototype inplace io pipe unpack regexp 41 | deprecated exiting glob digit printf utf8 layer 42 | reserved parenthesis taint closure semicolon); 43 | no warnings qw(exec newline); 44 | 45 | BEGIN { 46 | if ($^V >= 5.011) { 47 | require feature; 48 | feature->import( qw(say state switch) ); 49 | feature->unimport( qw(unicode_strings) ); 50 | } 51 | elsif( $^V >= 5.090005 ) { 52 | require feature; 53 | feature->import( qw(say state switch) ); 54 | require mro; 55 | mro->import('c3'); 56 | } 57 | else { 58 | # no features ( 59 | } 60 | } 61 | 62 | no utf8; 63 | #use open qw(:raw); 64 | 65 | #use utf8; 66 | #use open qw(:utf8 :std); 67 | 68 | BEGIN { 69 | $HINTS = $^H & ~$HINTS; 70 | $WARNS = ${^WARNING_BITS} & ~( $WARNS || ("\0" x length ${^WARNING_BITS}) ); 71 | my %h = %{^H}; 72 | delete @h{ keys %HINTS }; 73 | %HINTS = %h; 74 | } 75 | 76 | sub dumper($) { 77 | require Data::Dumper; 78 | my $s = Data::Dumper->new([@_]) 79 | ->Terse(1) 80 | ->Indent(1) 81 | ->Purity(0) 82 | ->Useqq(1) 83 | ->Quotekeys(0) 84 | ->Dump; 85 | $s =~ s{\n+$}{}s; 86 | $s; 87 | } 88 | 89 | #printf "package #hide\n\t%s;\n\n", $package; 90 | printf "package %s;\n\n", $package; 91 | 92 | while () { 93 | if (/^SELFBEGIN/) { 94 | printf ' defined ${^WARNING_BITS}'."\n". 95 | ' ? ${^WARNING_BITS} ^= ${^WARNING_BITS} ^ "%s"'."\n". 96 | ' : ${^WARNING_BITS} = "%s"'.";\n" 97 | , 98 | (join('', map "\\x$_", unpack "(H2)*", $WARNS))x2; 99 | printf " \$^H |= 0x%x;\n\n", $HINTS; 100 | for (keys %HINTS) { 101 | print " \$^H{'$_'} = ".dumper( $HINTS{$_}).";\n"; 102 | } 103 | } 104 | elsif (/^IMPORT/) { 105 | print " # use warnings\n"; 106 | printf ' ${^WARNING_BITS} ^= ${^WARNING_BITS} ^ "%s";'."\n\n", 107 | join '', map "\\x$_", unpack "(H2)*", $WARNS; 108 | 109 | print " # use strict, utf8, open, 5.010, ...\n"; 110 | printf " \$^H |= 0x%x;\n\n", $HINTS; 111 | 112 | print " # use feature qw(@{[ keys %HINTS ]})\n"; 113 | for (keys %HINTS) { 114 | print " \$^H{'$_'} = ".dumper( $HINTS{$_}).";\n"; 115 | } 116 | print "\n"; 117 | } 118 | elsif (/^UNIMPORT/) { 119 | # TODO 120 | print " # no warnings\n"; 121 | printf ' ${^WARNING_BITS} = "%s";'."\n\n", 122 | join '', map "\\x$_", unpack "(H2)*", $NOWARNS; 123 | 124 | print " # no strict, ...\n"; 125 | printf " \$^H &= ~0x%x;\n\n", $HINTS; 126 | 127 | print " # no feature qw(@{[ keys %HINTS ]})\n"; 128 | for (keys %HINTS) { 129 | print " delete \$^H{'$_'};\n"; 130 | } 131 | print "\n"; 132 | } 133 | else { 134 | print; 135 | } 136 | } 137 | 138 | close STDOUT; 139 | rename "$ARGV[0]~", $ARGV[0]; 140 | 141 | __DATA__ 142 | 143 | BEGIN { 144 | SELFBEGIN 145 | } 146 | m{ 147 | use strict; 148 | use warnings; 149 | }x; 150 | 151 | use Scalar::Util 'weaken', 'refaddr'; 152 | 153 | BEGIN { 154 | for my $sub (qw(carp croak confess)) { 155 | no strict 'refs'; 156 | *$sub = sub { 157 | my $caller = caller; 158 | local *__ANON__ = $caller .'::'. $sub; 159 | require Carp; 160 | *{ $caller.'::'.$sub } = \&{ 'Carp::'.$sub }; 161 | goto &{ 'Carp::'.$sub }; 162 | }; 163 | } 164 | } 165 | 166 | sub import { 167 | my $me = shift; 168 | my $caller = caller; 169 | local $^W; 170 | IMPORT 171 | no strict 'refs'; 172 | for my $sub (qw(carp croak confess)) { 173 | *{ $caller .'::'. $sub } = \&$sub; 174 | } 175 | return if $caller =~ /^$me/; 176 | while (@_) { 177 | my $feature = shift; 178 | if ($feature =~ s/^://) { 179 | if (defined &{ $feature }) { 180 | *{ $caller .'::'. $feature } = \&$feature; 181 | } else { 182 | croak "Unknown feature: :$feature"; 183 | } 184 | } 185 | } 186 | return; 187 | } 188 | 189 | sub unimport { 190 | my $me = shift; 191 | my $caller = caller; 192 | local $^W; 193 | UNIMPORT 194 | return; 195 | } 196 | 197 | sub xd ($;$) { no strict 'refs'; 198 | if( eval{ require Devel::Hexdump; 1 }) { *{ caller().'::xd' } = \&Devel::Hexdump::xd; } 199 | else { *{ caller().'::xd' } = sub($;$) { my@a=unpack'(H2)*',$_[0];my$s=''; 200 | $s .= "@a[ $_*16 .. $_*16 + 7 ] @a[ $_*16+8 .. $_*16 + 15 ]\n" for (0..$#a/16); 201 | return $s; 202 | };} 203 | goto &{ caller().'::xd' }; 204 | } 205 | 206 | sub dumper(@) { 207 | eval { require uni::dumper; 1} or goto &dumper_dd; 208 | no strict 'refs'; 209 | *{ caller().'::dumper' } = \&uni::dumper::dumper; 210 | goto &{ caller().'::dumper' }; 211 | } 212 | 213 | sub dumper_dd (@) { 214 | require Data::Dumper; 215 | no strict 'refs'; 216 | *{ caller().'::dumper' } = sub (@) { 217 | my $s = Data::Dumper->new([@_]) 218 | ->Freezer('DUMPER_freeze') 219 | ->Terse(1) 220 | ->Indent(1) 221 | ->Purity(0) 222 | ->Useqq(1) 223 | ->Quotekeys(0) 224 | ->Dump; 225 | $s =~ s/\\x\{([a-f0-9]{1,4})\}/chr hex $1/sge; 226 | $s; 227 | }; 228 | goto &{ caller().'::dumper' }; 229 | } 230 | 231 | 1; 232 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | LICENSE 2 | 3 | This program is free software; you can redistribute it and/or modify it 4 | under the same terms as Perl itself. 5 | 6 | Copyright (c) 2010-2013 Mons Anderson 7 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | benchmarks/anyevent-http-server-multicore.pl 2 | benchmarks/anyevent-http-server.pl 3 | benchmarks/anyevent-httpd.pl 4 | benchmarks/ev-raw.pl 5 | benchmarks/node.js 6 | benchmarks/psgi.pl 7 | benchmarks/starman-multicore.sh 8 | benchmarks/starman.sh 9 | benchmarks/twiggy.sh 10 | benchmarks/twisted.py 11 | bin/simple-server 12 | Changes 13 | Kit.pm.PL 14 | lib/AnyEvent/HTTP/Server.pm 15 | lib/AnyEvent/HTTP/Server/Req.pm 16 | lib/AnyEvent/HTTP/Server/WS.pm 17 | LICENSE 18 | Makefile.PL 19 | MANIFEST 20 | MANIFEST.SKIP 21 | README 22 | README.md 23 | t/00-load.t 24 | t/01-basic-ae.t 25 | t/02-basic-ev.t 26 | t/03-sendfile.t 27 | t/basic.pl 28 | t/pod.t 29 | t/testlib.pm 30 | test.sh 31 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | # Avoid version control files. 2 | \B\.git(?:ignore|)\b 3 | 4 | # Avoid Makemaker generated and utility files. 5 | \bMANIFEST\.bak 6 | ^MYMETA\. 7 | \bMakefile$ 8 | \bblib/ 9 | \bMakeMaker-\d 10 | \bpm_to_blib\.ts$ 11 | \bpm_to_blib$ 12 | \bblibdirs\.ts$ # 6.18 through 6.25 generated this 13 | 14 | # Avoid Module::Build generated and utility files. 15 | \bBuild$ 16 | \b_build/ 17 | 18 | # Avoid temp and backup files. 19 | ~$ 20 | \.old$ 21 | \#$ 22 | \b\.# 23 | \.bak$ 24 | \.rpm$ 25 | 26 | # Avoid Devel::Cover files. 27 | \bcover_db\b 28 | 29 | # Avoid local testing/dist files 30 | 31 | ^dist/ 32 | ^makeall\.sh$ 33 | ^tmp/ 34 | ^AnyEvent-HTTP-Server-.* 35 | Kit\.pm$ 36 | ^xt/ 37 | ^ex/ 38 | ^topdir- 39 | ^benchmarks/mojo 40 | ^benchmarks/nginx- 41 | -------------------------------------------------------------------------------- /META.json: -------------------------------------------------------------------------------- 1 | { 2 | "abstract" : "AnyEvent HTTP/1.1 Server", 3 | "author" : [ 4 | "Mons Anderson " 5 | ], 6 | "dynamic_config" : 0, 7 | "generated_by" : "ExtUtils::MakeMaker version 7.62, 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" : "AnyEvent-HTTP-Server", 16 | "no_index" : { 17 | "directory" : [ 18 | "t", 19 | "inc" 20 | ] 21 | }, 22 | "prereqs" : { 23 | "build" : { 24 | "requires" : { 25 | "ExtUtils::MakeMaker" : "0" 26 | } 27 | }, 28 | "configure" : { 29 | "requires" : { 30 | "ExtUtils::MakeMaker" : "0" 31 | } 32 | }, 33 | "runtime" : { 34 | "requires" : { 35 | "AnyEvent" : "5", 36 | "Digest::SHA1" : "2", 37 | "HTTP::Easy" : "0.02", 38 | "JSON::XS" : "3" 39 | } 40 | } 41 | }, 42 | "release_status" : "stable", 43 | "version" : "1.99998", 44 | "x_serialization_backend" : "JSON::PP version 4.06" 45 | } 46 | -------------------------------------------------------------------------------- /META.yml: -------------------------------------------------------------------------------- 1 | --- 2 | abstract: 'AnyEvent HTTP/1.1 Server' 3 | author: 4 | - 'Mons Anderson ' 5 | build_requires: 6 | ExtUtils::MakeMaker: '0' 7 | configure_requires: 8 | ExtUtils::MakeMaker: '0' 9 | dynamic_config: 0 10 | generated_by: 'ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010' 11 | license: perl 12 | meta-spec: 13 | url: http://module-build.sourceforge.net/META-spec-v1.4.html 14 | version: '1.4' 15 | name: AnyEvent-HTTP-Server 16 | no_index: 17 | directory: 18 | - t 19 | - inc 20 | requires: 21 | AnyEvent: '5' 22 | Digest::SHA1: '2' 23 | HTTP::Easy: '0.02' 24 | JSON::XS: '3' 25 | version: '1.99998' 26 | x_serialization_backend: 'CPAN::Meta::YAML version 0.018' 27 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008008; 2 | use ExtUtils::MakeMaker; 3 | BEGIN{ $ENV{AUTHOR} and require CPAN::Meta and CPAN::Meta->import(); }; 4 | 5 | WriteMakefile( 6 | NAME => 'AnyEvent::HTTP::Server', 7 | VERSION_FROM => 'lib/AnyEvent/HTTP/Server.pm', 8 | PREREQ_PM => { 9 | AnyEvent => 5, 10 | 'Digest::SHA1' => 2, 11 | 'JSON::XS' => 3, 12 | 'HTTP::Easy' => 0.04, 13 | 'Class::XSAccessor' => 0, 14 | }, 15 | ABSTRACT_FROM => 'lib/AnyEvent/HTTP/Server.pm', # retrieve abstract from module 16 | AUTHOR => 'Mons Anderson ', 17 | LICENSE => 'perl', 18 | PL_FILES => { "Kit.pm.PL" => '$(INST_LIB)/AnyEvent/HTTP/Server/Kit.pm' }, 19 | clean => { FILES => "Kit.pm" }, 20 | ); 21 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | NAME 2 | AnyEvent::HTTP::Server - AnyEvent HTTP/1.1 Server 3 | 4 | SYNOPSIS 5 | use AnyEvent::HTTP::Server; 6 | my $s = AnyEvent::HTTP::Server->new( 7 | host => '0.0.0.0', 8 | port => 80, 9 | cb => sub { 10 | my $request = shift; 11 | my $status = 200; 12 | my $content = "

Reply message

"; 13 | my $headers = { 'content-type' => 'text/html' }; 14 | $request->reply($status, $content, headers => $headers); 15 | } 16 | ); 17 | $s->listen; 18 | 19 | ## you may also prefork on N cores: 20 | 21 | # fork() ? next : last for (1..$N-1); 22 | 23 | ## Of course this is very simple example 24 | ## don't use such prefork in production 25 | 26 | $s->accept; 27 | 28 | my $sig = AE::signal INT => sub { 29 | warn "Stopping server"; 30 | $s->graceful(sub { 31 | warn "Server stopped"; 32 | EV::unloop; 33 | }); 34 | }; 35 | 36 | EV::loop; 37 | 38 | DESCRIPTION 39 | AnyEvent::HTTP::Server is a very fast asynchronous HTTP server written 40 | in perl. It has been tested in high load production environments and may 41 | be considered both fast and stable. 42 | 43 | One can easily implement own HTTP daemon with AnyEvent::HTTP::Server and 44 | Daemond::Lite module, both found at 45 | 46 | This is a second verson available as AnyEvent-HTTP-Server-II. The first 47 | version is now obsolette. 48 | 49 | HANDLING REQUEST 50 | You can handle HTTP request by passing cb parameter to 51 | AnyEvent::HTTP::Server->new() like this: 52 | 53 | my $dispatcher = sub { 54 | my $request = shift; 55 | #... Request processing code goes here ... 56 | 1; 57 | }; 58 | 59 | my $s = AnyEvent::HTTP::Server->new( host => '0.0.0.0', port => 80, cb => $dispatcher,); 60 | 61 | $dispatcher coderef will be called in a list context and it's return 62 | value should resolve to true, or request processing will be aborted by 63 | AnyEvent:HTTP::Server. 64 | 65 | One able to process POST requests by returning specially crafted hash 66 | reference from cb parameter coderef ($dispatcher in out example). This 67 | hash must contain the form key, holding a code reference. If 68 | conetnt-encoding header is application/x-www-form-urlencoded, form 69 | callback will be called. 70 | 71 | my $post_action = sub { 72 | my ( $request, $form ) = @_; 73 | $request->reply( 74 | 200, # HTTP Status 75 | "You just send long_data_param_name value of $form->{long_data_param_name}", # Content 76 | headers=> { 'content-type' =< 'text/plain'}, # Response headers 77 | ); 78 | } 79 | 80 | my $dispatcher = sub { 81 | my $request = shift; 82 | 83 | if ( $request->headers->{'content-type'} =~ m{^application/x-www-form-urlencoded\s*$} ) { 84 | return { 85 | form => sub { 86 | $cb->( $request, $post_action); 87 | }, 88 | }; 89 | } else { 90 | # GET request processing 91 | } 92 | 93 | }; 94 | 95 | my $s = AnyEvent::HTTP::Server->new( host => '0.0.0.0', port => 80, cb => $dispatcher,); 96 | 97 | EXPORT 98 | Does not export anything 99 | 100 | SUBROUTINES/METHODS 101 | new - create HTTP Server object 102 | Arguments to constractor should be passed as a key=>value list, for example 103 | 104 | my $s = AnyEvent::HTTP::Server->new( 105 | host => '0.0.0.0', 106 | port => 80, 107 | cb => sub { 108 | my $req = shift; 109 | return sub { 110 | my ($is_last, $bodypart) = @_; 111 | $r->reply(200, "

Reply message

", headers => { 'content-type' => 'text/html' }); 112 | } 113 | } 114 | ); 115 | 116 | host 117 | Specify interfaces to bind a listening socket to 118 | Example: host => '127.0.0.1' 119 | 120 | port 121 | Listen on this port 122 | Example: port => 80 123 | 124 | cb 125 | This coderef will be called on incoming request 126 | Example: cb => sub { 127 | my $request = shift; 128 | my $status = 200; 129 | my $content = "

Reply message

"; 130 | my $headers = { 'content-type' => 'text/html' }; 131 | $request->reply($status, $content, headers => $headers); 132 | } 133 | 134 | The first argument to callback will be request object (AnyEvent::HTTP::Server::Req). 135 | 136 | listen - bind server socket to host and port, start listening for connections 137 | This method has no arguments. 138 | 139 | This method is commonly called from master process before it forks. 140 | 141 | Errors in host and port may result in exceptions, so you probably want to eval this call. 142 | 143 | accept - start accepting connections 144 | This method has no arguments. 145 | 146 | This method is commonly called in forked children, which serve incoming requests. 147 | 148 | noaccept - stop accepting connections (while still listening on a socket) 149 | This method has no arguments. 150 | 151 | graceful - Stop accepting new connections and gracefully shut down the server 152 | Wait until all connections will be handled and execute supplied coderef after that. 153 | This method can be useful in signal handlers. 154 | 155 | set_favicon - change default favicon.ico 156 | The only argument is a scalar, containing binary representation of icon. 157 | Favicon will have content type set to 'image/x-icon' 158 | 159 | RESOURCES 160 | * GitHub repository 161 | 162 | 163 | 164 | ACKNOWLEDGEMENTS 165 | * Thanks to Marc Lehmann for AnyEvent 166 | 167 | * Thanks to Robin Redeker for AnyEvent::HTTPD 168 | 169 | AUTHOR 170 | Mons Anderson, 171 | 172 | LICENSE 173 | This program is free software; you can redistribute it and/or modify it 174 | under the terms of either: the GNU General Public License as published 175 | by the Free Software Foundation; or the Artistic License. 176 | 177 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # AnyEvent::HTTP::Server 2 | 3 | *Fast HTTP/1.1 server component for AnyEvent Framework* 4 | 5 | There is a previous implementation, that anybody could look to (http://github.com/Mons/AnyEvent-HTTP-Server), but it will never be on CPAN 6 | 7 | If you just plan to use something for HTTP, better to look deeper into this version. 8 | 9 | If you lack some functionality, please, open ticket or ask me. Maybe it could be easily added. 10 | 11 | ## Rationale 12 | 13 | This module is a complete rewrite of previous version. Previous was not so slow, but It will slower than python's Twisted http server or node.js' http server. Also it was much slower than Twiggy. 14 | 15 | Current implementation contains no XS and it is faster, than Twiggy with XS HTTP parser. Later I will enhance it with XS. 16 | 17 | ## Warning 18 | 19 | *This is early development release. I'll try not to change interfaces in major, but some things may be a bit changed* 20 | 21 | ## Benchmarks 22 | 23 | Benchmarking tool 24 | weighttp -c 100 -n 10000 http://localhost:8080/ 25 | 26 | Example app 27 | HTTP server on port 8080, which should reply with string "Good" 28 | 29 | All files are located under benchmaks/ 30 | 31 | * AnyEvent::HTTP::Server-II (1 worker) 32 | 33 | finished in 1 sec, 295 millisec and 127 microsec, **7721** req/s, 912 kbyte/s 34 | 35 | 36 | * AnyEvent::HTTP::Server-II ( **4** workers) 37 | 38 | finished in 0 sec, 552 millisec and 381 microsec, **18103** req/s, 2139 kbyte/s 39 | 40 | 41 | * AnyEvent::HTTP::Server (previous) 42 | 43 | finished in 3 sec, 421 millisec and 143 microsec, **2922** req/s, 278 kbyte/s 44 | 45 | 46 | * AnyEvent::HTTPD (v0.93t) 47 | 48 | finished in 18 sec, 622 millisec and 941 microsec, **536** req/s, 99 kbyte/s 49 | 50 | 51 | * Twiggy (v0.1021) 52 | 53 | finished in 1 sec, 630 millisec and 908 microsec, **6131** req/s, 272 kbyte/s 54 | 55 | 56 | * Starman (--workers 1) (v0.3006) 57 | 58 | finished in 2 sec, 469 millisec and 571 microsec, **4049** req/s, 511 kbyte/s 59 | 60 | 61 | * Starman (--workers **4**) (best for my 4 core) 62 | 63 | finished in 1 sec, 102 millisec and 631 microsec, **9069** req/s, 1161 kbyte/s 64 | 65 | 66 | * Pyton Twisted (I'm not a python programmer, so code may be not efficient) 67 | 68 | finished in 4 sec, 122 millisec and 587 microsec, **2425** req/s, 355 kbyte/s 69 | 70 | 71 | * Node.js 72 | 73 | finished in 1 sec, 766 millisec and 696 microsec, **5660** req/s, 790 kbyte/s 74 | 75 | 76 | * Nginx 77 | 78 | location / { perl 'use nginx; sub { $_[0]->send_http_header(q{text/plain}); $_[0]->print(q{Good}); return OK; }'; } 79 | 80 | finished in 0 sec, 290 millisec and 380 microsec, **34437** req/s, 5515 kbyte/s 81 | 82 | * Raw TCP/HTTP server (perl+ev with no logic or parsing) 83 | 84 | For source look into benchmarks/ev-raw.pl 85 | 86 | finished in 0 sec, 306 millisec and 259 microsec, **32652** req/s, 2678 kbyte/s 87 | -------------------------------------------------------------------------------- /benchmarks/anyevent-http-server-multicore.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use FindBin;use lib "$FindBin::Bin/../blib/lib"; 4 | use AnyEvent::HTTP::Server; 5 | use EV; 6 | my $server = AnyEvent::HTTP::Server->new( 7 | cb => sub { 8 | return 200, "Good"; 9 | }, 10 | ); 11 | 12 | $server->listen; 13 | 14 | for (1..4) { 15 | my $pid = fork(); 16 | if ($pid) { 17 | next; 18 | } else { 19 | last; 20 | } 21 | } 22 | 23 | $server->accept; 24 | EV::loop(); 25 | -------------------------------------------------------------------------------- /benchmarks/anyevent-http-server.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use FindBin;use lib "$FindBin::Bin/../blib/lib"; 4 | use AnyEvent::HTTP::Server; 5 | use EV; 6 | my $server = AnyEvent::HTTP::Server->new( 7 | cb => sub { 8 | return 200, "Good"; 9 | }, 10 | ); 11 | 12 | $server->listen; 13 | $server->accept; 14 | EV::loop(); 15 | -------------------------------------------------------------------------------- /benchmarks/anyevent-httpd.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use AnyEvent::HTTPD; 4 | use EV; 5 | my $server = AnyEvent::HTTPD->new( port => 8080 ); 6 | $server->reg_cb( 7 | '/' => sub { 8 | return$_[1]->respond({ content => ['text/html', "Good"] }); 9 | }, 10 | ); 11 | 12 | $server->run; 13 | EV::loop(); 14 | -------------------------------------------------------------------------------- /benchmarks/ev-raw.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | #use strict; 4 | use EV; 5 | #use AnyEvent::Impl::Perl; 6 | use AnyEvent; 7 | use AnyEvent::Socket; 8 | #use Errno; 9 | 10 | tcp_server 0, 8080, sub { 11 | binmode my $fh = shift, ':raw'; 12 | my $rw;$rw = AE::io $fh, 0, sub { 13 | if ( sysread ( $fh, my $buf, 1024*40 ) > 0 ) { 14 | syswrite( $fh, "HTTP/1.1 200 OK\015\012Connection:close\015\012Content-Type:text/plain\015\012Content-Length:4\015\012\015\012Good" ); 15 | undef $rw; 16 | } 17 | elsif ($! == Errno::EAGAIN) { 18 | return; 19 | } 20 | else { 21 | undef $rw; 22 | } 23 | }; 24 | }; 25 | 26 | #AnyEvent::Loop::run() 27 | EV::loop; 28 | -------------------------------------------------------------------------------- /benchmarks/node.js: -------------------------------------------------------------------------------- 1 | var http = require('http'); 2 | http.createServer(function (req, res) { 3 | res.writeHead(200, {'Content-Type': 'text/plain'}); 4 | res.end('Good'); 5 | }).listen(8080, "0.0.0.0"); 6 | console.log('Server running at http://0.0.0.0:8080/'); 7 | -------------------------------------------------------------------------------- /benchmarks/psgi.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env twiggy 2 | 3 | # Run me as twiggy --listen :PORT psgi.pl 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use AnyEvent; 9 | use Plack::Request; 10 | 11 | # Ensure presence 12 | use HTTP::Parser::XS; 13 | use EV; 14 | 15 | sub app { 16 | my $env = shift; 17 | 18 | my $req = Plack::Request->new($env); 19 | if ($req->path_info eq '/') { 20 | return sub { 21 | my $respond = shift; 22 | 23 | my $w = $respond->([200, ['Content-Type' => 'text/plain']]); 24 | $w->write("Good"); 25 | } 26 | } 27 | 28 | [404, ['Content-Type' => 'text/plain'], ['Not found']]; 29 | } 30 | 31 | \&app; 32 | -------------------------------------------------------------------------------- /benchmarks/starman-multicore.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | starman --listen :8080 --workers 4 psgi.pl 4 | -------------------------------------------------------------------------------- /benchmarks/starman.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | starman --listen :8080 --workers 1 psgi.pl 4 | -------------------------------------------------------------------------------- /benchmarks/twiggy.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | twiggy --listen :8080 psgi.pl 4 | -------------------------------------------------------------------------------- /benchmarks/twisted.py: -------------------------------------------------------------------------------- 1 | from twisted.web import server, resource 2 | from twisted.internet import reactor 3 | 4 | class HelloResource(resource.Resource): 5 | isLeaf = True 6 | numberRequests = 0 7 | 8 | def render_GET(self, request): 9 | self.numberRequests += 1 10 | request.setHeader("content-type", "text/html") 11 | return "Good" 12 | 13 | reactor.listenTCP(8080, server.Site(HelloResource())) 14 | reactor.run() 15 | -------------------------------------------------------------------------------- /bin/simple-server: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use FindBin; 5 | use lib "$FindBin::Bin/../lib", "$FindBin::Bin/../blib/lib"; 6 | use Sys::Hostname; 7 | use Getopt::Long; 8 | use Cwd 'cwd','abs_path'; 9 | use POSIX 'strftime'; 10 | use AnyEvent::HTTP::Server 0.02; 11 | use File::Spec; 12 | use EV; 13 | BEGIN { 14 | if( eval { require File::MimeInfo; 1 } ) { 15 | File::MimeInfo->import('mimetype'); 16 | } else { 17 | *mimetype = sub { 'application/octet-stream' }; 18 | } 19 | } 20 | 21 | my $host = hostname(); 22 | 23 | GetOptions( 24 | 'p|port=s' => \( my $port = 3080 ), 25 | 'l|listen=s' => \( my $addr = 0 ), 26 | ); 27 | 28 | my $path = abs_path(shift) // cwd(); 29 | 30 | warn "Serving $host ($addr:$port) ($path)\n"; 31 | 32 | my $s = AnyEvent::HTTP::Server->new( 33 | host => $addr, 34 | port => $port, 35 | cb => sub { 36 | my $r = shift; 37 | my $dironly = substr( $r->path, -1,1 ) eq '/'; 38 | my $p = File::Spec->canonpath( $r->path || '/' ); 39 | 40 | $p =~ s{\./}{}sg; 41 | $p =~ s{/+$}{}s; 42 | 1 while $p =~ s{\.\./[^/]+}{}sg; 43 | 1 while $p =~ s{\.\./}{}sg; 44 | my $rel = File::Spec->canonpath( $p ); 45 | $p = $path.'/'.$p; 46 | $p =~ s{/+}{/}sg; 47 | $p = File::Spec->canonpath( $p ); 48 | my $type = "X"; 49 | my $status = 404; 50 | my $mime; 51 | if (-d $p) { 52 | if (-f "$p/index.html") { $p = "$p/index.html"; $dironly = 0; } 53 | elsif (-f "$p/index.htm") { $p = "$p/index.htm"; $dironly = 0; } 54 | } 55 | if (-d $p) { 56 | $type = "D"; 57 | my $content = dirindex($p, $rel); 58 | $r->reply($status = 200, $content, headers => { 'content-type' => 'text/html' }); 59 | } 60 | elsif (-e $p) { 61 | $type = -f _ ? "F" : "Z"; 62 | if ($dironly) { 63 | $r->go($rel); 64 | $status = 302; 65 | $type .= "/"; 66 | $mime = "-> $rel"; 67 | } else { 68 | $mime = mimetype( $p ); 69 | $r->sendfile($status = 200, $p, headers => { 'content-disposition' => 'inline', 'content-type' => $mime }); 70 | } 71 | } 72 | printf STDERR "[%s] %-2s %-3s %s %s -> %s : (%s)\n", 73 | strftime("%b %d %H:%M:%S", localtime()), 74 | $type, $status, 75 | $r->method, 76 | $r->path, $p, 77 | $mime 78 | ; 79 | return if $type eq 'X'; 80 | return; 81 | }, 82 | ); 83 | my ($h,$p) = $s->listen; 84 | $s->accept; 85 | warn "Started at http://$h:$p"; 86 | 87 | EV::loop;(); 88 | 89 | sub e($) { 90 | local $_ = shift; 91 | s{&}{&}sg; 92 | s{<}{<}sg; 93 | s{>}{>}sg; 94 | s{"}{"}sg; # " 95 | s{'}{'}sg; # ' 96 | $_; 97 | } 98 | 99 | sub sz($) { 100 | my $size = shift; 101 | my @sizes = qw( b K M G T ); 102 | while ($size > 1024 and @sizes > 1) { 103 | $size /= 1024; 104 | shift @sizes; 105 | } 106 | return sprintf +(int($size) == $size ? '%d%s' : '%0.1f%s'), $size, $sizes[0]; 107 | } 108 | 109 | 110 | sub dirindex($$) { 111 | my ($real,$web) = @_; 112 | my $body = sprintf q{

Directory index for %s/ (%s/)

}, e $web, e $real; 113 | opendir(my $d, $real) or die "$!"; 114 | my (@dots, @dirs, @files); 115 | while (defined( $_ = readdir($d) )) { 116 | next if $web eq '' and /^\.\.?$/; 117 | if (-d $_ and !/^\.\.?$/) { 118 | push @dirs, $_; 119 | } 120 | elsif( /^\.\.?$/ ) { 121 | push @dots, $_ if $web ne ''; 122 | } 123 | else { 124 | push @files, $_; 125 | } 126 | } 127 | @dirs = sort { lc($a) cmp lc ($b) } @dirs; 128 | @files = sort { lc($a) cmp lc ($b) } @files; 129 | for (@dots, @dirs, @files) { 130 | next if $web eq '' and /^\.\.?$/; 131 | my $fx = $real.'/'.$_; 132 | $body .= ''; 133 | my ($stat, $date); 134 | if (-f $fx) { 135 | my @stat = stat _; 136 | $stat = sz($stat[7]); 137 | $date = strftime("%Y-%m-%d %H:%M:%S",localtime($stat[9])); 138 | } else { 139 | } 140 | $body .= sprintf 141 | q{}, 142 | e +File::Spec->canonpath( $web.'/'.$_ ), 143 | e $_.(-d $fx ? "/" : ''), 144 | $stat, 145 | $date, 146 | ; 147 | } 148 | $body .= "
%s%s%s
"; 149 | return $body; 150 | } 151 | -------------------------------------------------------------------------------- /ex/hdl_ex.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use FindBin; 5 | use lib "$FindBin::Bin/../blib/lib"; 6 | use Getopt::Long; 7 | use AnyEvent::Socket; 8 | use AnyEvent::Handle; 9 | use AnyEvent::HTTP::Server; 10 | use File::Spec; 11 | use EV; 12 | 13 | use Data::Dumper; 14 | 15 | my $s;$s = AnyEvent::HTTP::Server->new( 16 | host => 0, 17 | port => undef, 18 | cb => sub { 19 | $s or return; 20 | my $r = $_[0]; 21 | return HANDLE => sub { 22 | my $h = $_[0]; 23 | $h->on_read(sub { 24 | #warn Dumper \@_; 25 | my $h = shift; 26 | warn "got message:<$h->{rbuf}>"; 27 | }); 28 | } 29 | }, 30 | ); 31 | 32 | my ($h,$p) = $s->listen; 33 | $s->accept; 34 | 35 | tcp_connect $h,$p,sub { 36 | my $fh = shift or return warn "$!"; 37 | my $h = AnyEvent::Handle->new( 38 | fh => $fh, 39 | on_error => sub { warn "error: @_" }, 40 | on_eof => sub { warn "error: @_" }, 41 | ); 42 | my $body = "GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"; 43 | #warn 'written '.length($body).' bytes'; 44 | $h->push_write($body); 45 | $h->push_write('test message'); 46 | }; 47 | 48 | EV::loop; 49 | 50 | 51 | 1; 52 | -------------------------------------------------------------------------------- /ex/ws_ex.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use FindBin; 5 | use lib "$FindBin::Bin/../blib/lib"; 6 | use Sys::Hostname; 7 | use Getopt::Long; 8 | use Cwd 'cwd','abs_path'; 9 | use AnyEvent::Handle; 10 | use AnyEvent::HTTP::Server; 11 | use File::Spec; 12 | use EV; 13 | 14 | my $host = hostname(); 15 | 16 | GetOptions( 17 | 'p|port=s' => \( my $port = 3080 ), 18 | 'l|listen=s' => \( my $addr = '127.0.0.1' ), 19 | ); 20 | 21 | my $path = abs_path(shift) // cwd(); 22 | 23 | warn "Serving $host ($addr:$port) ($path)\n"; 24 | 25 | my $s = AnyEvent::HTTP::Server->new( 26 | host => $addr, 27 | port => $port, 28 | cb => sub { 29 | my $r = shift; 30 | if ( $r->uri =~ m{^/ws} ) { 31 | if ($r->is_websocket) { 32 | return $r->upgrade(ping_interval => 0,sub { 33 | if (my $ws = shift) { 34 | warn 'websocket established'; 35 | $ws->onmessage(sub { 36 | my $data = shift; 37 | warn("client message recv: $data"); 38 | }); 39 | $ws->onclose(sub { 40 | undef $ws; 41 | warn "websocket closed"; 42 | }); 43 | } else { 44 | warn "something wrong:$!"; 45 | EV::unloop; 46 | } 47 | }); 48 | } 49 | else { 50 | return $r->reply(400,'websocket headers required'); 51 | } 52 | } 53 | else { 54 | return $r->reply(200,_get_html()); 55 | } 56 | }, 57 | ); 58 | my ($h,$p) = $s->listen; 59 | $s->accept; 60 | 61 | warn "Started at http://$h:$p"; 62 | EV::loop; 63 | 64 | sub _get_html { 65 | < 67 | 68 | 75 | 111 | 112 | 113 |
114 | 115 | 116 |
117 | 118 | 119 | HTML 120 | } 121 | 122 | 123 | 1; 124 | -------------------------------------------------------------------------------- /ex/ws_ex_delayed.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use FindBin; 5 | use lib "$FindBin::Bin/../blib/lib"; 6 | use Sys::Hostname; 7 | use Getopt::Long; 8 | use Cwd 'cwd','abs_path'; 9 | use AnyEvent::Handle; 10 | use AnyEvent::HTTP::Server; 11 | use File::Spec; 12 | use EV; 13 | 14 | my $host = hostname(); 15 | 16 | GetOptions( 17 | 'p|port=s' => \( my $port = 3080 ), 18 | 'l|listen=s' => \( my $addr = '127.0.0.1' ), 19 | ); 20 | 21 | my $path = abs_path(shift) // cwd(); 22 | 23 | warn "Serving $host ($addr:$port) ($path)\n"; 24 | 25 | my $s = AnyEvent::HTTP::Server->new( 26 | host => $addr, 27 | port => $port, 28 | cb => sub { 29 | my $r = shift; 30 | if ( $r->uri =~ m{^/ws} ) { 31 | if ($r->is_websocket) { 32 | return HANDLE => sub { 33 | my $handle = shift; 34 | $r->upgrade(ping_interval => 0,h => $handle,sub { 35 | if (my $ws = shift) { 36 | warn 'websocket established!!!'; 37 | $ws->onmessage(sub { 38 | my $data = shift; 39 | warn("client message recv: $data"); 40 | }); 41 | $ws->onclose(sub { 42 | undef $ws; 43 | warn "websocket closed"; 44 | }); 45 | } else { 46 | warn "something wrong:$!"; 47 | EV::unloop; 48 | } 49 | }); 50 | }; 51 | } else { 52 | $r->reply(400,'websocket headers required'); 53 | return 54 | } 55 | } else { 56 | return $r->reply(200,_get_html()); 57 | } 58 | }, 59 | ); 60 | my ($h,$p) = $s->listen; 61 | $s->accept; 62 | 63 | warn "Started at http://$h:$p"; 64 | EV::loop; 65 | 66 | sub _get_html { 67 | < 69 | 70 | 77 | 113 | 114 | 115 |
116 | 117 | 118 |
119 | 120 | 121 | HTML 122 | } 123 | 124 | 125 | 1; 126 | -------------------------------------------------------------------------------- /lib/AnyEvent/HTTP/Server.pm: -------------------------------------------------------------------------------- 1 | package AnyEvent::HTTP::Server; 2 | 3 | =head1 NAME 4 | 5 | AnyEvent::HTTP::Server - AnyEvent HTTP/1.1 Server 6 | 7 | =cut 8 | 9 | our $VERSION; 10 | BEGIN{ 11 | $VERSION = '1.99998'; 12 | } 13 | 14 | use AnyEvent::HTTP::Server::Kit; 15 | 16 | use AnyEvent; 17 | use AnyEvent::Socket; 18 | use AnyEvent::Handle; 19 | use Scalar::Util 'refaddr', 'weaken'; 20 | use Errno qw(EAGAIN EINTR); 21 | use AnyEvent::Util qw(WSAEWOULDBLOCK guard AF_INET6 fh_nonblocking); 22 | use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR IPPROTO_TCP TCP_NODELAY); 23 | 24 | use Carp (); 25 | use Encode (); 26 | use Compress::Zlib (); 27 | use MIME::Base64 (); 28 | use Time::HiRes qw/gettimeofday/; 29 | 30 | use AnyEvent::HTTP::Server::Req; 31 | 32 | our $MIME = Encode::find_encoding('MIME-Header'); 33 | 34 | sub MAX_READ_SIZE () { 128 * 1024 } 35 | sub DEBUG () { 0 } 36 | 37 | our $LF = "\015\012"; 38 | my $ico_pk = pack "H*", 39 | "1f8b08000000000000ff636060044201010620a9c090c1c2c020c6c0c0a001c4". 40 | "4021a008441c0c807242dc100c03ffffff1f1418e2144c1a971836fd308c4f3f". 41 | "08373434609883ac06248fac161b9b16fe47772736bfe1b29f1efa89713f363b". 42 | "08d98d1ceec4b89f5cfd84dc8f4f3f480e19131306a484ffc0610630beba9e81". 43 | "e1e86206860bcc10fec966289ecfc070b01d48b743d820b187cd0c707d000409". 44 | "1d8c7e040000"; 45 | our $ico = Compress::Zlib::memGunzip $ico_pk; 46 | 47 | our $ERROR_TEMPLATE = <<"EOD"; 48 | 49 | %1\$s %2\$s 50 | 51 |

%1\$s %2\$s

52 |
${\__PACKAGE__}/$VERSION
53 | 54 | 55 | EOD 56 | 57 | sub start { croak "It's a new version of ".__PACKAGE__.". For old version use `legacy' branch, or better make some minor patches to support new version" }; 58 | sub stop { croak "It's a new version of ".__PACKAGE__.". For old version use `legacy' branch, or better make some minor patches to support new version" }; 59 | 60 | sub new { 61 | my $pkg = shift; 62 | my $self = bless { 63 | backlog => 1024, 64 | read_size => MAX_READ_SIZE, 65 | max_header_size => MAX_READ_SIZE, 66 | request => 'AnyEvent::HTTP::Server::Req', 67 | sockets => {}, 68 | @_, 69 | active_requests => 0, 70 | active_connections => 0, 71 | }, $pkg; 72 | 73 | if ($self->{max_header_size} > $self->{read_size}) { 74 | Carp::croak "max_header_size can't be greater than read_size"; 75 | } 76 | 77 | eval qq{ use $self->{request}; 1} 78 | or die "Request $self->{request} not loaded: $@"; 79 | 80 | if (exists $self->{listen}) { 81 | $self->{listen} = [ $self->{listen} ] unless ref $self->{listen}; 82 | my %dup; 83 | for (@{ $self->{listen} }) { 84 | if($dup{ lc $_ }++) { 85 | croak "Duplicate host $_ in listen\n"; 86 | } 87 | my ($h,$p) = split ':',$_,2; 88 | $h = '0.0.0.0' if $h eq '*'; 89 | $h = length ( $self->{host} ) ? $self->{host} : '0.0.0.0' unless length $h; 90 | $p = length ( $self->{port} ) ? $self->{port} : 8080 unless length $p; 91 | $_ = join ':',$h,$p; 92 | } 93 | ($self->{host},$self->{port}) = split ':',$self->{listen}[0],2; 94 | } else { 95 | $self->{listen} = [ join(':',$self->{host},$self->{port}) ]; 96 | } 97 | 98 | $self->can("handle_request") 99 | and croak "It's a new version of ".__PACKAGE__.". For old version use `legacy' branch, or better make some minor patches to support new version"; 100 | 101 | if (!exists $self->{favicon}) { 102 | $self->{favicon} = \$ico; 103 | }; 104 | if ($self->{favicon} and !ref $self->{favicon}) { 105 | $self->{favicon} = \do { 106 | open my $f, '<:raw', $self->{favicon} or die "Can't open favicon: $!"; 107 | local $/; 108 | <$f>; 109 | }; 110 | } 111 | $self->set_favicon( ${ $self->{favicon} } ); 112 | 113 | return $self; 114 | } 115 | 116 | sub AnyEvent::HTTP::Server::destroyed::AUTOLOAD {} 117 | sub destroy { %{ bless $_[0], 'AnyEvent::HTTP::Server::destroyed' } = (); } 118 | sub DESTROY { $_[0]->destroy }; 119 | 120 | 121 | sub set_favicon { 122 | my $self = shift; 123 | my $icondata = shift; 124 | if ($icondata) { 125 | $self->{ico} = "HTTP/1.1 200 OK${LF}Connection:close${LF}Content-Type:image/x-icon${LF}Content-Length:".length($icondata)."${LF}${LF}".$icondata; 126 | } 127 | else { 128 | delete $self->{ico}; 129 | } 130 | } 131 | 132 | sub listen:method { 133 | my $self = shift; 134 | 135 | for my $listen (@{ $self->{listen} }) { 136 | my $fh; 137 | unless ($self->{sockets}->{$listen}) { 138 | my ($host,$service) = split ':',$listen,2; 139 | $service = $self->{port} unless length $service; 140 | $host = $self->{host} unless length $host; 141 | $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6 ? "::" : "0" unless length $host; 142 | 143 | my $ipn = parse_address $host 144 | or Carp::croak "$self.listen: cannot parse '$host' as host address"; 145 | 146 | my $af = address_family $ipn; 147 | 148 | # win32 perl is too stupid to get this right :/ 149 | Carp::croak "listen/socket: address family not supported" 150 | if AnyEvent::WIN32 && $af == AF_UNIX; 151 | 152 | socket $fh, $af, SOCK_STREAM, 0 or Carp::croak "listen/socket: $!"; 153 | 154 | if ($af == AF_INET || $af == AF_INET6) { 155 | setsockopt $fh, SOL_SOCKET, SO_REUSEADDR, 1 156 | or Carp::croak "listen/so_reuseaddr: $!" 157 | unless AnyEvent::WIN32; # work around windows bug 158 | 159 | unless ($service =~ /^\d*$/) { 160 | $service = (getservbyname $service, "tcp")[2] 161 | or Carp::croak "tcp_listen: $service: service unknown" 162 | } 163 | } elsif ($af == AF_UNIX) { 164 | unlink $service; 165 | } 166 | 167 | bind $fh, AnyEvent::Socket::pack_sockaddr( $service, $ipn ) 168 | or Carp::croak "listen/bind on ".eval{Socket::inet_ntoa($ipn)}.":$service: $!"; 169 | 170 | if ($host eq 'unix/') { 171 | chmod oct('0777'), $service 172 | or warn "chmod $service failed: $!"; 173 | } 174 | } else { 175 | $fh = delete $self->{sockets}->{$listen}; 176 | } 177 | 178 | fh_nonblocking $fh, 1; 179 | 180 | $self->{fh} ||= $fh; # compat 181 | $self->{fhs}{fileno $fh} = $fh; 182 | $self->{fhs_named}{$listen} = $fh; 183 | } 184 | 185 | for my $socket (values %{ $self->{sockets} }) { 186 | close $socket; 187 | } 188 | $self->{sockets} = {}; 189 | 190 | $self->prepare(); 191 | 192 | for ( values %{ $self->{fhs} } ) { 193 | listen $_, $self->{backlog} 194 | or Carp::croak "listen/listen on ".(fileno $_).": $!"; 195 | } 196 | 197 | return wantarray ? do { 198 | my ($service, $host) = AnyEvent::Socket::unpack_sockaddr( getsockname $self->{fh} ); 199 | (format_address $host, $service); 200 | } : (); 201 | } 202 | 203 | sub prepare {} 204 | 205 | sub accept:method { 206 | weaken( my $self = shift ); 207 | for my $fl ( values %{ $self->{fhs} }) { 208 | $self->{aws}{ fileno $fl } = AE::io $fl, 0, sub { 209 | while ($fl and (my $peer = accept my $fh, $fl)) { 210 | AnyEvent::Util::fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not 211 | if ($self->{want_peer}) { 212 | my ($service, $host) = AnyEvent::Socket::unpack_sockaddr $peer; 213 | $self->incoming($fh, AnyEvent::Socket::format_address $host, $service); 214 | } else { 215 | $self->incoming($fh); 216 | } 217 | } 218 | }; 219 | } 220 | return; 221 | } 222 | 223 | sub noaccept { 224 | my $self = shift; 225 | delete $self->{aws}; 226 | } 227 | 228 | sub drop { 229 | my ($self,$id,$err) = @_; 230 | $err =~ s/\015//sg; 231 | warn "Dropping connection $id: $err (by request from @{[ (caller)[1,2] ]})" if DEBUG; # or $self->{debug}; 232 | my $r = delete $self->{$id} or return; 233 | $self->{active_connections}--; 234 | %{ $r } = () if $r; 235 | 236 | if ($self->{graceful} ) { 237 | if ( 238 | $self->{active_requests} == 0 239 | # and $self->{active_connections} == 0 240 | and 0+keys %{ $self->{wss} } == 0 241 | ) { 242 | ( delete $self->{graceful} )->(); 243 | } 244 | else { 245 | warn "wait for $self->{active_requests} / @{[ 0+keys %{ $self->{wss} } ]} for graceful shutdown"; 246 | } 247 | } 248 | } 249 | 250 | sub req_wbuf_len { 251 | my $self = shift; 252 | my $req = shift; 253 | return undef unless exists $self->{ $req->headers->{INTERNAL_REQUEST_ID} }; 254 | return 0 unless exists $self->{ $req->headers->{INTERNAL_REQUEST_ID} }{wbuf}; 255 | return length ${ $self->{ $req->headers->{INTERNAL_REQUEST_ID} }{wbuf} }; 256 | } 257 | 258 | sub incoming { 259 | weaken( my $self = shift ); 260 | #warn "incoming @_"; 261 | $self->{total_connections}++; 262 | my ($fh,$rhost,$rport) = @_; 263 | my $id = ++$self->{seq}; #refaddr $fh; 264 | 265 | my %r = ( fh => $fh, id => $id ); 266 | my $buf; 267 | 268 | $self->{ $id } = \%r; 269 | $self->{active_connections}++; 270 | 271 | my $write = sub { 272 | $self and exists $self->{$id} or return; 273 | use Data::Dumper; 274 | for my $buf (@_) { 275 | ref $buf or do { $buf = \( my $str = $buf ); warn "Passed nonreference buffer from @{[ (caller)[1,2] ]}\n"; }; 276 | if ( $self->{$id}{wbuf} ) { 277 | $self->{$id}{closeme} and return warn "Write ($$buf) called while connection close was enqueued at @{[ (caller)[1,2] ]}"; 278 | ${ $self->{$id}{wbuf} } .= defined $$buf ? $$buf : return $self->{$id}{closeme} = 1; 279 | return; 280 | } 281 | elsif ( !defined $$buf ) { return $self->drop($id); } 282 | 283 | $self->{$id}{fh} or return do { 284 | warn "Lost filehandle while trying to send ".length($$buf)." data for $id"; 285 | $self->drop($id,"No filehandle"); 286 | (); 287 | }; 288 | my $w = syswrite( $self->{$id}{fh}, $$buf ); 289 | if ($w == length $$buf) { 290 | # ok; 291 | } 292 | elsif (defined $w) { 293 | substr($$buf,0,$w,''); 294 | $self->{$id}{wbuf} = $buf; 295 | $self->{$id}{ww} = AE::io $self->{$id}{fh}, 1, sub { 296 | warn "ww.io.$id" if DEBUG; 297 | $self and exists $self->{$id} or return; 298 | $w = syswrite( $self->{$id}{fh}, ${ $self->{$id}{wbuf} } ); 299 | if ($w == length ${ $self->{$id}{wbuf} }) { 300 | delete $self->{$id}{wbuf}; 301 | delete $self->{$id}{ww}; 302 | if( $self->{$id}{closeme} ) { $self->drop($id); } 303 | } 304 | elsif (defined $w) { 305 | ${ $self->{$id}{wbuf} } = substr( ${ $self->{$id}{wbuf} }, $w ); 306 | #substr( ${ $self->{$id}{wbuf} }, 0, $w, ''); 307 | } 308 | else { return $self->drop($id, "$!"); } 309 | }; 310 | } 311 | else { return $self->drop($id, "$!"); } 312 | } 313 | }; 314 | 315 | my $reply_error = sub { 316 | # my ($code,$message) = @_; 317 | $_[1] //= $AnyEvent::HTTP::Server::Req::http{$_[0]}; 318 | # warn "ERROR @_"; 319 | my $body = sprintf $ERROR_TEMPLATE, $_[0], $_[1]; 320 | my $reply = "HTTP/1.0 $_[0] $_[1]${LF}Connection:close${LF}Content-Type:text/html${LF}Content-Length:" 321 | .length($body)."${LF}${LF}".$body."\n"; 322 | $write->(\$reply,\undef); 323 | }; 324 | 325 | my ($state,$seq) = (0,0); 326 | my ($method,$uri,$version,$lastkey,$contstate,$bpos,$len,$pos, $req); 327 | 328 | my $ixx = 0; 329 | $r{rw} = AE::io $fh, 0, sub { 330 | #warn "rw.io.$id (".(fileno $fh).") seq:$seq (ok:".($self ? 1:0).':'.(( $self && exists $self->{$id}) ? 1 : 0).")" if DEBUG; 331 | $self and exists $self->{$id} or return; 332 | while ( $self and ( $len = sysread( $fh, $buf, $self->{read_size}-length $buf, length $buf ) ) ) { 333 | if ($state == 0) { 334 | if (( my $i = index($buf,"\012", $ixx) ) > -1) { 335 | if (substr($buf, $ixx, $i - $ixx) =~ /^(\S++) \040 (\S++) \040 HTTP\/(\d++\.\d++)\015?$/xso) { 336 | $method = $1; 337 | $uri = $2; 338 | $version = $3; 339 | $state = 1; 340 | $lastkey = undef; 341 | ++$seq; 342 | warn "Received request N.$seq over ".fileno($fh).": $method $uri" if DEBUG; 343 | $self->{active_requests}++; 344 | #push @{ $r{req} }, [{}]; 345 | } 346 | elsif (substr($buf, $ixx, $i - $ixx) =~ /^\015?$/) { 347 | # warn "Skip empty line"; 348 | $ixx = $i + 1; 349 | redo; 350 | } 351 | else { 352 | warn "Broken request ($i): <".substr($buf, $ixx, $i).">"; 353 | return $reply_error->(400); 354 | # return $self->drop($id, "Broken request ($i): <".substr($buf, $ixx, $i).">"); 355 | } 356 | $pos = $i+1; 357 | } else { 358 | if ($ixx > 0) { 359 | $buf = substr($buf,$ixx); 360 | $pos = $ixx = 0; 361 | } 362 | elsif ( length($buf) >= $self->{max_header_size} ) { 363 | return $reply_error->(413); 364 | } 365 | warn "Need more data" if DEBUG; 366 | return; # need more 367 | } 368 | } 369 | my %h = ( INTERNAL_REQUEST_ID => $id, defined $rhost ? ( Remote => $rhost, RemotePort => $rport ) : () ); 370 | if ($state == 1) { 371 | # headers 372 | pos($buf) = $pos; 373 | warn "Parsing headers from pos $pos:".substr($buf,$pos) if DEBUG; 374 | while () { 375 | #warn "parse line >'".substr( $buf,pos($buf),index( $buf, "\012", pos($buf) )-pos($buf) )."'"; 376 | $bpos = pos($buf); 377 | if( $buf =~ /\G ([^:\000-\037\040]++)[\011\040]*+:[\011\040]*+ ([^\012\015;]*+(;)?[^\012\015]*+) \015?\012/sxogc ){ 378 | $lastkey = lc $1; 379 | $h{ $lastkey } = exists $h{ $lastkey } ? $h{ $lastkey }.','.$2: $2; 380 | #warn "Captured header $lastkey = '$2'"; 381 | if ( defined $3 ) { 382 | pos(my $v = $2) = $-[3] - $-[2]; 383 | #warn "scan ';'"; 384 | $h{ $lastkey . '+' . lc($1) } = ( defined $2 ? do { my $x = $2; $x =~ s{\\(.)}{$1}gs; $x } : $3 ) 385 | while ( $v =~ m{ \G ; \s* ([^\s=]++)\s*= (?: "((?:[^\\"]++|\\.){0,4096}+)" | ([^;,\s]++) ) \s* }gcxso ); # " 386 | $contstate = 1; 387 | } else { 388 | $contstate = 0; 389 | } 390 | } 391 | elsif ($buf =~ /\G[\011\040]+/sxogc) { # continuation 392 | #warn "Continuation"; 393 | if (length $lastkey) { 394 | unless ($buf =~ /\G ([^\015\012;]*+(;)?[^\015\012]*+) \015?\012/sxogc) { 395 | if ($ixx > 0) { 396 | $pos = $bpos - $ixx; 397 | $buf = substr($buf,$ixx); 398 | $ixx = 0; 399 | } 400 | elsif ( length($buf) >= $self->{max_header_size} ) { 401 | $self->{active_requests}--; 402 | return $reply_error->(413); 403 | } 404 | warn "Need more data" if DEBUG; 405 | return; # need more 406 | }; 407 | # $buf =~ /\G ([^\015\012;]*+(;)?[^\015\012]*+) \015?\012/sxogc or return pos($buf) = $bpos; # need more data; 408 | $h{ $lastkey } .= ' '.$1; 409 | if ( ( defined $2 or $contstate ) ) { 410 | #warn "With ;"; 411 | if ( ( my $ext = index( $h{ $lastkey }, ';', rindex( $h{ $lastkey }, ',' ) + 1) ) > -1 ) { 412 | # Composite field. Need to reparse last field value (from ; after last ,) 413 | # full key rescan, because of possible case: 414 | # regexp needed to set \G 415 | pos($h{ $lastkey }) = $ext; 416 | #warn "Rescan from $ext"; 417 | #warn("<$1><$2><$3>"), 418 | $h{ $lastkey . '+' . lc($1) } = ( defined $2 ? do { my $x = $2; $x =~ s{\\(.)}{$1}gs; $x } : $3 ) 419 | while ( $h{ $lastkey } =~ m{ \G ; \s* ([^\s=]++)\s*= (?: "((?:[^\\"]++|\\.){0,4096}+)" | ([^;,\s]++) ) \s* }gcxso ); # " 420 | $contstate = 1; 421 | } 422 | } 423 | } 424 | } 425 | elsif ($buf =~ /\G\015?\012/sxogc) { 426 | #warn "Last line"; 427 | last; 428 | } 429 | elsif($buf =~ /\G [^\012]* \Z/sxogc) { 430 | if ($ixx > 0) { 431 | $pos = $bpos - $ixx; 432 | $buf = substr($buf,$ixx); 433 | $ixx = 0; 434 | } 435 | elsif ( length($buf) >= $self->{max_header_size} ) { 436 | $self->{active_requests}--; 437 | return $reply_error->(413); 438 | } 439 | warn "Need more data" if DEBUG; 440 | return; # need more 441 | } 442 | else { 443 | my ($line) = $buf =~ /\G([^\015\012]++)(?:\015?\012|\Z)/sxogc; 444 | warn "Drop: bad header line: '$line'"; 445 | $self->{active_requests}--; 446 | # $self->drop($id, "Bad header line: '$line'"); # TBD 447 | return $reply_error->(400); 448 | } 449 | } 450 | 451 | #warn Dumper \%h; 452 | $pos = pos($buf); 453 | 454 | $self->{total_requests}++; 455 | 456 | if ( $self->{ico} and $method eq "GET" and $uri =~ m{^/favicon\.ico( \Z | \? )}sox ) { 457 | $write->(\$self->{ico}); 458 | $write->(\undef) if lc $h{connecton} =~ /^close\b/; 459 | $self->{active_requests}--; 460 | $ixx = $pos + $h{'content-length'}; 461 | } 462 | elsif ( $method eq 'PING' ) { 463 | my ( $header_str, $content ) = ref $self->{ping_sub} eq 'CODE' ? $self->{ping_sub}->() : ('200 OK', 'Pong '.time()."\n"); 464 | my $str = "HTTP/1.1 $header_str${LF}Connection:close${LF}Content-Type:text/plain${LF}Content-Length:".length($content)."${LF}${LF}".$content; 465 | $write->(\$str); 466 | $write->(\undef); 467 | $self->{active_requests}--; 468 | $ixx = $pos + $h{'content-length'}; 469 | } 470 | elsif ( $self->{ping} and $method eq "GET" and $uri =~ m{^/ping( \Z | \? )}sox ) { 471 | my ( $header_str, $content ) = ref $self->{ping_sub} eq 'CODE' ? $self->{ping_sub}->() : ('200 OK', 'Pong'); 472 | my $str = "HTTP/1.1 $header_str${LF}Connection:close${LF}Content-Type:text/plain${LF}Content-Length:".length($content)."${LF}${LF}".$content; 473 | $write->(\$str); 474 | $write->(\undef) if lc $h{connecton} =~ /^close\b/; 475 | $self->{active_requests}--; 476 | $ixx = $pos + $h{'content-length'}; 477 | } 478 | else { 479 | #warn "Create request object"; 480 | $req = $self->{request}->new( 481 | method => $method, 482 | uri => $uri, 483 | headers => \%h, 484 | writer => $write, 485 | reqcount => \$self->{active_requests}, 486 | server => $self, 487 | version => $version, 488 | ); 489 | my @rv = $self->{cb}->($req); 490 | #my @rv = $self->{cb}->( $req = bless [ $method, $uri, \%h, $write ], 'AnyEvent::HTTP::Server::Req' ); 491 | if (@rv) { 492 | if (ref $rv[0] eq 'CODE') { 493 | $r{on_body} = $rv[0]; 494 | } 495 | elsif ( ref $rv[0] eq 'HASH' ) { 496 | if ( $h{'content-type'} =~ m{^ 497 | multipart/form-data\s*;\s* 498 | boundary\s*=\s* 499 | (?: 500 | "((?:[^\\"]++|\\.){0,4096})" # " quoted entry 501 | | 502 | ([^;,\s]+) 503 | ) 504 | $}xsio and exists $rv[0]{multipart} 505 | ) { 506 | 507 | my $bnd = '--'.( defined $1 ? do { my $x = $1; $x =~ s{\\(.)}{$1}gs; $x } : $2 ); 508 | my $body = ''; 509 | #warn "reading multipart with boundary '$bnd'"; 510 | #warn "set on_body"; 511 | my $cb = $rv[0]{multipart}; 512 | $r{on_body} = sub { 513 | my ($last,$part) = @_; 514 | if ( length($body) + length($$part) > $self->{max_body_size} ) { 515 | # TODO; 516 | } 517 | $body .= $$part; 518 | #warn "Checking body '".$body."'"; 519 | my $idx = index( $body, $bnd ); 520 | while ( $idx > -1 and ( 521 | ( $idx + length($bnd) + 1 <= length($body) and substr($body,$idx+length($bnd),1) eq "\012" ) 522 | or 523 | ( $idx + length($bnd) + 2 <= length($body) and substr($body,$idx+length($bnd),2) eq "\015\012" ) 524 | or 525 | ( $idx + length($bnd) + 2 <= length($body) and substr($body,$idx+length($bnd),2) eq "\055\055" ) 526 | ) ) { 527 | #warn "have part"; 528 | my $part = substr($body,$idx-2,1) eq "\015" ? substr($body,0,$idx-2) : substr($body,0,$idx-1); 529 | #warn Dumper $part; 530 | #substr($part, 0, ( substr($part,0,1) eq "\015" ) ? 2 : 1,''); 531 | #warn "captured $idx: '$part'"; 532 | $body = substr($body,$idx + length $bnd); 533 | substr($body,0, ( substr($body,0,1) eq "\015" ) ? 2 : 1 ,''); 534 | #warn "body = '$body'"; 535 | $idx = index( $body, $bnd ); 536 | #warn "next part idx: $idx"; 537 | length $part or next; 538 | #warn "Process part '$part'"; 539 | 540 | my %hd; 541 | my $lk; 542 | while() { 543 | if( $part =~ /\G ([^:\000-\037\040]++)[\011\040]*+:[\011\040]*+ ([^\012\015;]++(;)?[^\012\015]*+) \015?\012/sxogc ){ 544 | $lk = lc $1; 545 | $hd{ $lk } = exists $hd{ $lk } ? $hd{ $lk }.','.$2 : $2; 546 | if ( defined $3 ) { 547 | pos(my $v = $2) = $-[3] - $-[2]; 548 | # TODO: testme 549 | $hd{ $lk . '+' . lc($1) } = ( defined $2 ? do { my $x = $2; $x =~ s{\\(.)}{$1}gs; $x } : $3 ) 550 | while ( $v =~ m{ \G ; \s* ([^\s=]++)\s*= (?: "((?:[^\\"]++|\\.){0,4096}+)" | ([^;,\s]++) ) \s* }gcxso ); # " 551 | } 552 | } 553 | elsif ($part =~ /\G[\011\040]+/sxogc and length $lk) { # continuation 554 | $part =~ /\G([^\015\012]+)\015?\012/sxogc or next; 555 | $hd{ $lk } .= ' '.$1; 556 | if ( ( my $ext = index( $hd{ $lk }, ';', rindex( $hd{ $lk }, ',' ) + 1) ) > -1 ) { 557 | # Composite field. Need to reparse last field value (from ; after last ,) 558 | pos($hd{ $lk }) = $ext; 559 | $hd{ $lk . '+' . lc($1) } = ( defined $2 ? do { my $x = $2; $x =~ s{\\(.)}{$1}gs; $x } : $3 ) 560 | while ( $hd{ $lk } =~ m{ \G ; \s* ([^\s=]++)\s*= (?: "((?:[^\\"]++|\\.){0,4096}+)" | ([^;,\s]++) ) \s* }gcxso ); # " 561 | } 562 | } 563 | elsif ($part =~ /\G\015?\012/sxogc) { 564 | last; 565 | } 566 | elsif($part =~ /\G [^\012]* \Z/sxogc) { 567 | # Truncated part??? 568 | last; 569 | } 570 | else { 571 | pos($part) = 0; 572 | last; 573 | } 574 | } 575 | substr($part, 0,pos($part),''); 576 | my $enc = lc $hd{'content-transfer-encoding'}; 577 | if ( $enc eq 'quoted-printable' ) { $part = $MIME->decode( $part ); } 578 | elsif ( $enc eq 'base64' ) { $part = MIME::Base64::decode_base64( $part ); } 579 | $hd{filename} = $hd{'content-disposition+filename'} if exists $hd{'content-disposition+filename'}; 580 | $hd{name} = $hd{'content-disposition+name'} if exists $hd{'content-disposition+name'}; 581 | #warn "call for part $hd{name} ($last)"; 582 | $cb->( $last && $idx == -1 ? 1 : 0,$part,\%hd ); 583 | } 584 | }; 585 | } 586 | elsif ( exists $rv[0]{form} ) { 587 | my $body = ''; 588 | $r{on_body} = sub { 589 | my ($last,$part) = @_; 590 | if ( length($body) + length($$part) > $self->{max_body_size} ) { 591 | # TODO; 592 | } 593 | $body .= $$part; 594 | if ($last) { 595 | $rv[0]{form}( $req->form($body), $body ); 596 | delete $r{on_body}; 597 | } 598 | }; 599 | } 600 | elsif( exists $rv[0]{raw} ) { 601 | $r{on_body} = $rv[0]{raw}; 602 | } 603 | else { 604 | die "XXX"; 605 | } 606 | } 607 | elsif ($rv[0] eq 'HANDLE') { 608 | delete $r{rw}; 609 | my $h = AnyEvent::Handle->new( 610 | fh => $fh, 611 | ); 612 | $h->{rbuf} = substr($buf,$pos); 613 | #warn "creating handle ".Dumper $h->{rbuf}; 614 | $req->writer(sub { 615 | my $rbuf = shift; 616 | if (defined $$rbuf) { 617 | if ($h) { 618 | $h->push_write( $$rbuf ); 619 | } 620 | else { 621 | warn "Requested write '$$rbuf' on destroyed handle"; 622 | } 623 | } else { 624 | if ($h) { 625 | $h->push_shutdown; 626 | $h->on_drain(sub { 627 | $h->destroy; 628 | undef $h; 629 | }); 630 | undef $h; 631 | } 632 | } 633 | }); 634 | $req->handle($h); 635 | $rv[1]->($h); 636 | $h->{__cnn_drop_guard} = guard { 637 | # use postpone to unroll destruction loop 638 | # waiting for request to decrement active_resuests 639 | AE::postpone { 640 | $self->drop($id) if $self; 641 | }; 642 | }; 643 | weaken($req); 644 | %r = ( ); 645 | return; 646 | } 647 | elsif ( $rv[0] ) { 648 | $req->reply(@rv); 649 | } 650 | else { 651 | #warn "Other rv"; 652 | } 653 | } 654 | } 655 | weaken($req); 656 | 657 | if( $len = $h{'content-length'} ) { 658 | #warn "have clen"; 659 | if ( length($buf) - $pos == $len ) { 660 | #warn "Equally"; 661 | $r{on_body} && (delete $r{on_body})->( 1, \(substr($buf,$pos)) ); 662 | $buf = '';$state = $ixx = 0; 663 | #TEST && test_visited("finish:complete content length") 664 | # FINISHED 665 | #warn "1. finished request" . Dumper $req; 666 | return; 667 | } 668 | elsif ( length($buf) - $pos > $len ) { 669 | #warn "Complete body + trailing (".( length($buf) - $pos - $len )." bytes: ".substr( $buf,$pos + $len ).")"; 670 | $r{on_body} && (delete $r{on_body})->( 1, \(substr($buf,$pos,$pos+$len)) ); 671 | $ixx = $pos + $len; 672 | $state = 0; 673 | # FINISHED 674 | #warn "2. finished request" . Dumper $req; 675 | redo; 676 | } 677 | else { 678 | #warn "Not enough body"; 679 | $r{left} = $len - ( length($buf) - $pos ); 680 | if ($r{on_body}) { 681 | $r{on_body}( 0, \(substr($buf,$pos)) ) if $pos < length $buf; 682 | $state = 2; 683 | } else { 684 | $state = 2; 685 | } 686 | $buf = ''; $ixx = 0; 687 | return; 688 | } 689 | } 690 | #elsif (chunked) { TODO } 691 | else { 692 | #warn "No clen"; 693 | $r{on_body}(1,\('')) if $r{on_body}; 694 | # FINISHED 695 | #warn "3. finished request" . Dumper($req); 696 | #warn "pos = $pos, lbuf=".length $buf; 697 | #return %r=() if $req->connection eq 'close'; 698 | $state = 0; 699 | if ($pos < length $buf) { 700 | $ixx = $pos; 701 | redo; 702 | } else { 703 | $buf = '';$state = $ixx = 0; 704 | return; 705 | } 706 | } 707 | } # state 1 708 | if ($state == 2 ) { 709 | #warn "partial ".Dumper( $ixx, $buf, substr($buf,$ixx) ); 710 | if (length($buf) - $ixx >= $r{left}) { 711 | #warn sprintf "complete (%d of %d)", length $buf, $r{left}; 712 | $r{on_body} && (delete $r{on_body})->( 1, \(substr($buf,$ixx, $r{left})) ); 713 | $buf = substr($buf,$ixx + $r{left}); 714 | $state = $ixx = 0; 715 | # FINISHED 716 | #warn "4. finished request" . Dumper $req; 717 | #return $self->drop($id) if $req->connection eq 'close'; 718 | #$ixx = $pos + $r{left}; 719 | #$state = 0; 720 | redo; 721 | } else { 722 | #warn sprintf "not complete (%d of %d)", length $buf, $r{left}; 723 | $r{on_body} && $r{on_body}( 0, \(substr($buf,$ixx)) ); 724 | $r{left} -= ( length($buf) - $ixx ); 725 | $buf = ''; $ixx = 0; 726 | #return; 727 | next; 728 | } 729 | } 730 | #state 3: discard body 731 | 732 | #$r{_activity} = $r{_ractivity} = AE::now; 733 | #$write->(\("HTTP/1.1 200 OK\r\nContent-Length:10\r\n\r\nTestTest1\n"),\undef); 734 | } # while read 735 | return unless $self and exists $self->{$id}; 736 | if (defined $len) { 737 | $! = Errno::EPIPE; # warn "EOF from client ($len)"; 738 | } else { 739 | return if $! == EAGAIN or $! == EINTR or $! == WSAEWOULDBLOCK; 740 | } 741 | $self->drop($id, "$!"); 742 | }; # io 743 | } 744 | 745 | sub ws_close { 746 | my $self = shift; 747 | for (values %{ $self->{wss} }) { 748 | $_ && $_->close(); 749 | } 750 | } 751 | 752 | sub graceful { 753 | my $self = shift; 754 | my $cb = pop; 755 | delete $self->{aws}; 756 | close $_ for values %{ $self->{fhs} }; 757 | 758 | warn "Graceful shutdown: req=$self->{active_requests} / cnn=$self->{active_connections} / wss=@{[ 0+keys %{ $self->{wss} } ]}\n";# if DEBUG or $self->{debug}; 759 | 760 | if ( 761 | $self->{active_requests} == 0 762 | # and $self->{active_connections} == 0 763 | and 0+keys %{ $self->{wss} } == 0 764 | ) { 765 | $cb->(); 766 | } 767 | else { 768 | $self->{graceful} = $cb; 769 | $self->ws_close(); 770 | } 771 | } 772 | 773 | 774 | 1; # End of AnyEvent::HTTP::Server 775 | __END__ 776 | 777 | =head1 SYNOPSIS 778 | 779 | use AnyEvent::HTTP::Server; 780 | my $s = AnyEvent::HTTP::Server->new( 781 | host => '0.0.0.0', 782 | port => 80, 783 | cb => sub { 784 | my $request = shift; 785 | my $status = 200; 786 | my $content = "

Reply message

"; 787 | my $headers = { 'content-type' => 'text/html' }; 788 | $request->reply($status, $content, headers => $headers); 789 | } 790 | ); 791 | $s->listen; 792 | 793 | ## you may also prefork on N cores: 794 | 795 | # fork() ? next : last for (1..$N-1); 796 | 797 | ## Of course this is very simple example 798 | ## don't use such prefork in production 799 | 800 | $s->accept; 801 | 802 | my $sig = AE::signal INT => sub { 803 | warn "Stopping server"; 804 | $s->graceful(sub { 805 | warn "Server stopped"; 806 | EV::unloop; 807 | }); 808 | }; 809 | 810 | EV::loop; 811 | 812 | =head1 DESCRIPTION 813 | 814 | AnyEvent::HTTP::Server is a very fast asynchronous HTTP server written in perl. 815 | It has been tested in high load production environments and may be considered both fast and stable. 816 | 817 | One can easily implement own HTTP daemon with AnyEvent::HTTP::Server and Daemond::Lite module, 818 | both found at L 819 | 820 | This is a second verson available as AnyEvent-HTTP-Server-II. The first version is now obsolette. 821 | 822 | =head1 HANDLING REQUEST 823 | 824 | You can handle HTTP request by passing cb parameter to AnyEvent::HTTP::Server->new() like this: 825 | 826 | 827 | my $dispatcher = sub { 828 | my $request = shift; 829 | #... Request processing code goes here ... 830 | 1; 831 | }; 832 | 833 | my $s = AnyEvent::HTTP::Server->new( host => '0.0.0.0', port => 80, cb => $dispatcher,); 834 | 835 | $dispatcher coderef will be called in a list context and it's return value should resolve 836 | to true, or request processing will be aborted by AnyEvent:HTTP::Server. 837 | 838 | One able to process POST requests by returning specially crafted hash reference from cb 839 | parameter coderef ($dispatcher in out example). This hash must contain the B
key, 840 | holding a code reference. If B header is 841 | B, form callback will be called. 842 | 843 | my $post_action = sub { 844 | my ( $request, $form ) = @_; 845 | $request->reply( 846 | 200, # HTTP Status 847 | "You just send long_data_param_name value of $form->{long_data_param_name}", # Content 848 | headers=> { 'content-type' =< 'text/plain'}, # Response headers 849 | ); 850 | } 851 | 852 | my $dispatcher = sub { 853 | my $request = shift; 854 | 855 | if ( $request->headers->{'content-type'} =~ m{^application/x-www-form-urlencoded\s*$} ) { 856 | return { 857 | form => sub { 858 | $cb->( $request, $post_action); 859 | }, 860 | }; 861 | } else { 862 | # GET request processing 863 | } 864 | 865 | }; 866 | 867 | my $s = AnyEvent::HTTP::Server->new( host => '0.0.0.0', port => 80, cb => $dispatcher,); 868 | 869 | =head1 EXPORT 870 | 871 | Does not export anything 872 | 873 | =head1 SUBROUTINES/METHODS 874 | 875 | =head2 new - create HTTP Server object 876 | 877 | Arguments to constractor should be passed as a key=>value list, for example 878 | 879 | my $s = AnyEvent::HTTP::Server->new( 880 | host => '0.0.0.0', 881 | port => 80, 882 | cb => sub { 883 | my $req = shift; 884 | return sub { 885 | my ($is_last, $bodypart) = @_; 886 | $r->reply(200, "

Reply message

", headers => { 'content-type' => 'text/html' }); 887 | } 888 | } 889 | ); 890 | 891 | 892 | =head3 host 893 | 894 | Specify interfaces to bind a listening socket to 895 | Example: host => '127.0.0.1' 896 | 897 | =head3 port 898 | 899 | Listen on this port 900 | Example: port => 80 901 | 902 | =head3 cb 903 | 904 | This coderef will be called on incoming request 905 | Example: cb => sub { 906 | my $request = shift; 907 | my $status = 200; 908 | my $content = "

Reply message

"; 909 | my $headers = { 'content-type' => 'text/html' }; 910 | $request->reply($status, $content, headers => $headers); 911 | } 912 | 913 | The first argument to callback will be request object (AnyEvent::HTTP::Server::Req). 914 | 915 | =head2 listen - bind server socket to host and port, start listening for connections 916 | 917 | This method has no arguments. 918 | 919 | This method is commonly called from master process before it forks. 920 | 921 | Errors in host and port may result in exceptions, so you probably want to eval this call. 922 | 923 | =head2 accept - start accepting connections 924 | 925 | This method has no arguments. 926 | 927 | This method is commonly called in forked children, which serve incoming requests. 928 | 929 | =head2 noaccept - stop accepting connections (while still listening on a socket) 930 | 931 | This method has no arguments. 932 | 933 | =head2 graceful - Stop accepting new connections and gracefully shut down the server 934 | 935 | Wait until all connections will be handled and execute supplied coderef after that. 936 | This method can be useful in signal handlers. 937 | 938 | =head2 set_favicon - change default favicon.ico 939 | 940 | The only argument is a scalar, containing binary representation of icon. 941 | Favicon will have content type set to 'image/x-icon' 942 | 943 | =head1 RESOURCES 944 | 945 | =over 4 946 | 947 | =item * GitHub repository 948 | 949 | L 950 | 951 | =back 952 | 953 | =head1 ACKNOWLEDGEMENTS 954 | 955 | =over 4 956 | 957 | =item * Thanks to B for L 958 | 959 | =item * Thanks to B for L 960 | 961 | =back 962 | 963 | =head1 AUTHOR 964 | 965 | Mons Anderson, 966 | 967 | =head1 LICENSE 968 | 969 | This program is free software; you can redistribute it and/or modify it 970 | under the terms of either: the GNU General Public License as published 971 | by the Free Software Foundation; or the Artistic License. 972 | 973 | =cut 974 | -------------------------------------------------------------------------------- /lib/AnyEvent/HTTP/Server/Req.pm: -------------------------------------------------------------------------------- 1 | package AnyEvent::HTTP::Server::Req; 2 | 3 | =head1 NAME 4 | 5 | AnyEvent::HTTP::Server::Req - Request object used by AnyEvent::HTTP::Server 6 | 7 | =head1 VERSION 8 | 9 | Version 1.97 10 | 11 | =cut 12 | 13 | { 14 | package #hide 15 | aehts::sv; 16 | use overload 17 | '""' => sub { ${$_[0]} }, 18 | '@{}' => sub { [${$_[0]}] }, 19 | fallback => 1; 20 | package #hide 21 | aehts::av; 22 | use overload 23 | '""' => sub { $_[0][0] }, 24 | fallback => 1; 25 | } 26 | 27 | use AnyEvent::HTTP::Server; 28 | use AnyEvent::HTTP::Server::Kit; 29 | use AnyEvent::HTTP::Server::WS; 30 | use Carp (); 31 | 32 | use HTTP::Easy::Cookies; 33 | use POSIX qw(strftime); 34 | 35 | use MIME::Base64 qw(encode_base64); 36 | use Scalar::Util qw(weaken); 37 | 38 | BEGIN { 39 | if(eval{ require Digest::SHA1 }) { 40 | Digest::SHA1->import('sha1'); 41 | } elsif(eval { require Digest::SHA }) { 42 | Digest::SHA->import('sha1'); 43 | } else { 44 | die 'need Digest::SHA1 or Digest::SHA'; 45 | } 46 | } 47 | our $Server = 'AEHTS/'.$AnyEvent::HTTP::Server::VERSION; 48 | our @hdr = map { lc $_ } 49 | our @hdrn = qw( 50 | Access-Control-Allow-Credentials Access-Control-Allow-Origin Access-Control-Allow-Headers 51 | Upgrade Connection Content-Type Content-Length WebSocket-Origin WebSocket-Location Sec-WebSocket-Origin Sec-Websocket-Location Sec-WebSocket-Key Sec-WebSocket-Accept Sec-WebSocket-Protocol DataServiceVersion 52 | Server 53 | X-Req-Id 54 | ); 55 | our %hdr; @hdr{@hdr} = @hdrn; 56 | our %hdri; @hdri{ @hdr } = 0..$#hdr; 57 | our $LF = "\015\012"; 58 | our $JSON; 59 | our $JSONP; 60 | our %http = do { 61 | local ($a,$b); 62 | my @w = qw(Content Entity Error Failed Found Gateway Large Proxy Request Required Timeout); 63 | map { ++$a;$b=0;map+(100*$a+$b++=>$_)x(!!$_),@$_; } 64 | ["Continue","Switching Protocols","Processing",], 65 | [qw(OK Created Accepted),"Non-Authoritative Information","No $w[0]","Reset $w[0]","Partial $w[0]","Multi-Status",], 66 | ["Multiple Choices","Moved Permanently","$w[4]","See Other","Not Modified","Use $w[7]",0,"Temporary Redirect",], 67 | ["Bad $w[8]","Unauthorized","Payment $w[9]","Forbidden","Not $w[4]","Method Not Allowed","Not Acceptable","$w[7] Authentication $w[9]","$w[8] $w[10]","Conflict","Gone","Length $w[9]","Precondition $w[3]","$w[8] $w[1] Too $w[6]","$w[8]-URI Too $w[6]","Unsupported Media Type","$w[8] Range Not Satisfiable","Expectation $w[3]",(0)x4,"Unprocessable $w[1]","Locked","$w[3] Dependency","No code","Upgrade $w[9]",(0)x22,"Retry with",], 68 | ["Internal Server $w[2]","Not Implemented","Bad $w[5]","Service Unavailable","$w[5] $w[10]","HTTP Version Not Supported","Variant Also Negotiates","Insufficient Storage",0,"Bandwidth Limit Exceeded","Not Extended",(0)x88,"Client $w[2]",], 69 | }; 70 | 71 | use constant { 72 | METHOD => 0, 73 | URI => 1, 74 | HEADERS => 2, 75 | WRITE => 3, 76 | CHUNKED => 4, 77 | PARSEDURI => 5, 78 | QUERY => 6, 79 | REQCOUNT => 7, 80 | SERVER => 8, 81 | TIME => 9, 82 | CTX => 10, 83 | HANDLE => 11, 84 | ATTRS => 12, 85 | }; 86 | 87 | our %WARNED; 88 | use overload '@{}' => sub { 89 | my $self = shift; 90 | my $caller = join ":", (caller)[1,2]; 91 | Carp::carp "Usage of ".ref($self)." as an ARRAYREF outside AEHTS is strictly awry (at $caller)" 92 | unless $WARNED{$caller}++; 93 | $self->{'@'} //= do { 94 | my $compat = [ 95 | $self->method, 96 | $self->uri, 97 | $self->headers, 98 | undef, # $self->writer, 99 | undef, # $self->chunked, 100 | $self->params, 101 | $self->query, 102 | undef, # $self->reqcount, 103 | $self->server, 104 | $self->reqtime, 105 | undef, 106 | $self->handle, 107 | $self->attrs, 108 | ]; 109 | # $compat->[ATTRS] = $self->attrs; 110 | # $compat->[HEADERS] = $self->headers; 111 | # $compat->[TIME] = $self->reqtime; 112 | # $compat->[HANDLE] = $self->handle; 113 | $compat; 114 | }; 115 | return $self->{'@'}; 116 | }, fallback => 1; 117 | 118 | use Class::XSAccessor 119 | # constructor => 'new', 120 | accessors => [qw( 121 | method 122 | uri 123 | headers 124 | server 125 | 126 | reqtime 127 | writer handle 128 | )], 129 | getters => [qw( 130 | path query params version 131 | )], 132 | ; 133 | 134 | sub new { 135 | my $class = shift; 136 | my %args = ( 137 | @_, 138 | reqtime => AE::now(), 139 | ); 140 | @args{qw(path query)} = 141 | $args{uri} =~ m{ ^ 142 | (?: 143 | (?:(?:(?:[a-z]+):|)//|) 144 | (?:[^/]+) 145 | |) 146 | (/[^?]*) 147 | (?: 148 | \? (.+|) 149 | | 150 | ) 151 | $ }xso 152 | ; 153 | $args{params} = +{ 154 | map { 155 | my ($k,$v) = split /=/,$_,2; 156 | +( url_unescape($k) => url_unescape($v) ) 157 | } split /&/, $args{query} 158 | }; 159 | return bless \%args, $class; 160 | } 161 | 162 | sub connection { 163 | $_[0]{headers}{connection} =~ /^([^;]+)/ && lc( $1 ) || 164 | ( $_[0]{version} >= 1.1 ? 'keep-alive' : 'close' ) 165 | } 166 | 167 | sub full_uri { 'http://' . $_[0]{headers}{host} . $_[0]{uri} } 168 | sub attrs { $_[0]{_} //= {} } 169 | 170 | sub url_unescape($) { 171 | return undef unless defined $_[0]; 172 | my $string = shift; 173 | $string =~ s/\+/ /sg; 174 | #return $string if index($string, '%') == -1; 175 | $string =~ s/%([[:xdigit:]]{2})/chr(hex($1))/ge; 176 | utf8::decode $string; 177 | return $string; 178 | } 179 | 180 | sub form { 181 | my %h; 182 | while ( $_[1] =~ m{ \G ([^=]+) = ([^&]*) ( & | \Z ) }gcxso ) { 183 | my $k = url_unescape($1); 184 | my $v = bless do{\(my $o = url_unescape($2))}, 'aehts::sv'; 185 | if (exists $h{$k}) { 186 | if (UNIVERSAL::isa($h{$k}, 'ARRAY')) { 187 | push @{$h{$k}},$v; 188 | } else { 189 | $h{$k} = bless [ $h{$k},$v ], 'aehts::av'; 190 | } 191 | } 192 | else { 193 | $h{$k} = $v; 194 | } 195 | } 196 | return \%h; 197 | } 198 | 199 | sub uri_parse { 200 | Carp::carp "Use of uri_parse is deprecated"; 201 | } 202 | 203 | sub param { 204 | if ($_[1]) { 205 | return $_[0]{params}{$_[1]}; 206 | } else { 207 | return keys %{ $_[0]{params} }; 208 | } 209 | } 210 | 211 | sub replyjs { 212 | my $self = shift; 213 | #warn "Replyjs: @_ by @{[ (caller)[1,2] ]}"; 214 | my ($code,$data,%args); 215 | $code = ref $_[0] ? 200 : shift; 216 | $data = shift; 217 | %args = @_; 218 | $args{headers} ||= {}; 219 | $args{headers}{'content-type'} ||= 'application/json'; 220 | my $pretty = delete $args{pretty}; 221 | my $callback_name = delete $args{jsonp_callback}; 222 | !$callback_name or $callback_name =~ /^[a-zA-Z_][0-9a-zA-Z_]*$/ or do { 223 | warn "jsonp callbackname is invalid $callback_name. Called from @{[ (caller)[1,2] ]}\n"; 224 | $self->reply(500,'{error: "Internal Server Error" }', %args); 225 | return; 226 | }; 227 | $JSON or do { 228 | eval { require JSON::XS;1 } 229 | or do { 230 | warn "replyjs required JSON::XS, which could not be loaded: $@. Called from @{[ (caller)[1,2] ]}\n"; 231 | $self->reply(500,'{error: "Internal Server Error" }', %args); 232 | return; 233 | }; 234 | $JSON = JSON::XS->new->utf8; 235 | $JSONP = JSON::XS->new->utf8->pretty; 236 | }; 237 | my $jdata = eval { 238 | ($pretty ? $JSONP : $JSON)->encode( $data ); 239 | }; 240 | defined $jdata or do { 241 | warn "Can't encode to JSON: $@ at @{[ (caller)[1,2] ]}\n"; 242 | $self->reply(500,'{error: "Internal Server Error"}', %args); 243 | return; 244 | }; 245 | $jdata =~ s{<}{\\u003c}sg; 246 | $jdata =~ s{>}{\\u003e}sg; 247 | $jdata = "$callback_name( $jdata );" if $callback_name; 248 | $self->reply( $code, $jdata, %args ); 249 | 250 | } 251 | 252 | sub sendfile { 253 | my $self = shift; 254 | my ( $code,$file,%args ) = @_; 255 | $code ||= 200; 256 | my $reply = "HTTP/1.0 $code $http{$code}$LF"; 257 | my $size = -s $file or $! and return warn "Can't sendfile `$file': $!"; 258 | open my $f, '<:raw',$file or return warn "Can't open file `$file': $!"; 259 | 260 | my @good;my @bad; 261 | my $h = { 262 | server => $Server, 263 | %{ $args{headers} || {} }, 264 | 'connection' => ( $args{headers} && $args{headers}{connection} ) ? $args{headers}{connection} : $self->connection, 265 | 'content-length' => $size, 266 | }; 267 | if (exists $h->{'content-type'}) { 268 | if( $h->{'content-type'} !~ m{[^;]+;\s*charset\s*=} 269 | and $h->{'content-type'} =~ m{(?:^(?:text/|application/(?:json|(?:x-)?javascript))|\+(?:json|xml)\b)}i) { 270 | $h->{'content-type'} .= '; charset=UTF-8'; 271 | } 272 | } else { 273 | $h->{'content-type'} = 'application/octet-stream'; 274 | } 275 | for (keys %$h) { 276 | if (exists $hdr{lc $_}) { $good[ $hdri{lc $_} ] = $hdr{ lc $_ }.": ".$h->{$_}; } 277 | else { push @bad, "\u\L$_\E: ".$h->{$_}; } 278 | } 279 | for (@good,@bad) { 280 | if (defined()) { 281 | s/[\r\n]+/ /g; 282 | $reply .= $_ . $LF; 283 | } 284 | } 285 | $reply .= $LF; 286 | if( $self->{writer} ) { 287 | $self->{writer}->( \$reply ); 288 | while ($size > 0) { 289 | my $l = sysread($f,my $buf,4096); 290 | defined $l or last; 291 | $size -= $l; 292 | $self->{writer}->( \$buf ); 293 | } 294 | $self->{writer}->( \undef ) if $h->{connection} eq 'close' or $self->server->{graceful}; 295 | delete $self->{writer}; 296 | } 297 | } 298 | 299 | sub go { 300 | my $self = shift; 301 | my $location = shift; 302 | my %args = @_; 303 | ( $args{headers} ||= {} )->{location} = $location; 304 | $self->reply( 302, "Moved", %args ); 305 | } 306 | 307 | sub reply { 308 | my $self = shift; 309 | #return $self->headers(@_) if @_ % 2; 310 | my ($code,$content,%args) = @_; 311 | $code ||= 200; 312 | $content = '' unless defined $content; 313 | utf8::encode $content if utf8::is_utf8 $content; 314 | my $reply = "HTTP/$self->{version} $code $http{$code}$LF"; 315 | my @good;my @bad; 316 | my $h = { 317 | server => $Server, 318 | %{ $args{headers} || {} }, 319 | 'connection' => ( $args{headers} && $args{headers}{connection} ) ? $args{headers}{connection} : $self->connection, 320 | }; 321 | if ($self->method ne 'HEAD') { 322 | if ( exists $h->{'content-length'} ) { 323 | if ($h->{'content-length'} != length($content)) { 324 | warn "Content-Length mismatch: replied: $h->{'content-length'}, expected: ".length($content); 325 | $h->{'content-length'} = length($content); 326 | } 327 | } else { 328 | $h->{'content-length'} = length($content); 329 | } 330 | } else { 331 | if ( exists $h->{'content-length'} ) { 332 | # keep it 333 | } 334 | elsif(length $content) { 335 | $h->{'content-length'} = length $content; 336 | } 337 | else { 338 | $h->{'transfer-encoding'} = 'chunked'; 339 | } 340 | $content = ''; 341 | } 342 | 343 | # https://www.rfc-editor.org/rfc/rfc7230#section-3.3.2 344 | if ($code == 204 or $code == 304 or $code < 200) { 345 | delete $h->{'content-length'}; 346 | $content = ''; 347 | } 348 | 349 | if (exists $h->{'content-type'}) { 350 | if( $h->{'content-type'} !~ m{[^;]+;\s*charset\s*=} 351 | and $h->{'content-type'} =~ m{(?:^(?:text/|application/(?:json|(?:x-)?javascript))|\+(?:json|xml)\b)}i) { 352 | $h->{'content-type'} .= '; charset=utf-8'; 353 | } 354 | } else { 355 | $h->{'content-type'} = 'text/html; charset=utf-8'; 356 | } 357 | my $nh = delete $h->{NotHandled}; 358 | 359 | # set multiple cookies 360 | if(ref $h->{'set-cookie'} eq 'ARRAY') { 361 | my $cookies = delete $h->{'set-cookie'}; 362 | 363 | #set-cookie is not in @hdr 364 | push(@bad, "Set-Cookie: ".$_.$LF) for(@{$cookies}); 365 | } 366 | 367 | for (keys %$h) { 368 | if (exists $hdr{lc $_}) { $good[ $hdri{lc $_} ] = $hdr{ lc $_ }.": ".$h->{$_}; } 369 | else { 370 | if (lc $_ eq 'set-cookie' ) { 371 | my $cookies = HTTP::Easy::Cookies->decode($h->{$_}); 372 | for my $d (keys %$cookies) { 373 | next if $d eq 'version'; 374 | for my $p (keys %{$cookies->{$d}}) { 375 | for my $n (keys %{$cookies->{$d}{$p}}) { 376 | my $o = $cookies->{$d}{$p}{$n}; 377 | my @c = $n . '=' . $o->{value}; 378 | push @c, "expires=" . strftime('%a, %d %b %Y %T GMT', gmtime($o->{expires})) if $o->{expires}; 379 | push @c, "domain=". $d; 380 | push @c, "path=" . $p; 381 | push @c, "Secure" if $o->{secure}; 382 | push @c, "HttpOnly" if $o->{httponly}; 383 | push @c, "SameSite=" . $o->{samesite} if $o->{samesite}; 384 | push @bad, "\u\Lset-cookie\E: ". join('; ',@c); 385 | } 386 | } 387 | } 388 | } else { 389 | push @bad, "\u\L$_\E: ".$h->{$_}; 390 | } 391 | } 392 | } 393 | for (@good,@bad) { 394 | if (defined()) { 395 | s/[\r\n]+/ /g; 396 | $reply .= $_ . $LF; 397 | } 398 | } 399 | # 2 is size of LF 400 | $self->attrs->{head_size} = length($reply) + 2; 401 | $self->attrs->{body_size} = length $content; 402 | $reply .= $LF.$content; 403 | #if (!ref $content) { $reply .= $content } 404 | if( $self->{writer} ) { 405 | $self->{writer}->( \$reply ); 406 | $self->{writer}->( \undef ) if $h->{connection} eq 'close' or $self->server->{graceful}; 407 | delete $self->{writer}; 408 | } 409 | if( $self->server && $self->server->{on_reply} ) { 410 | $h->{ResponseTime} = AE::now() - $self->reqtime; 411 | $h->{Status} = $code; 412 | $h->{NotHandled} = $nh if $nh; 413 | #eval { 414 | $self->server->{on_reply}->( 415 | $self, 416 | $h, 417 | ); 418 | #1} or do { 419 | # warn "on_reply died with $@"; 420 | #}; 421 | }; 422 | if( $self->server && $self->server->{stat_cb} ) { 423 | eval { 424 | $self->server->{stat_cb}->($self->path, $self->method, AE::now() - $self->reqtime); 425 | 1} or do { 426 | warn "stat_cb died with $@"; 427 | } 428 | }; 429 | } 430 | 431 | sub is_websocket { 432 | my $self = shift; 433 | return 1 if lc($self->headers->{connection}) eq 'upgrade' and lc( $self->headers->{upgrade} ) eq 'websocket'; 434 | return 0; 435 | } 436 | 437 | sub upgrade { 438 | my $self = shift; 439 | #my %h;$h{h} = \%h; $h{r} = $self; 440 | 441 | my $cb = pop; 442 | my %args = @_; 443 | if ( $self->headers->{'sec-websocket-version'} == 13 ) { 444 | my $key = $self->headers->{'sec-websocket-key'}; 445 | my $origin = exists $self->headers->{'sec-websocket-origin'} ? $self->headers->{'sec-websocket-origin'} : $self->headers->{'origin'}; 446 | my $accept = encode_base64(sha1( $key . '258EAFA5-E914-47DA-95CA-C5AB0DC85B11' )); 447 | chomp $accept; 448 | $self->send_headers( 101,headers => { 449 | %{ $args{headers} || {} }, 450 | upgrade => 'WebSocket', 451 | connection => 'Upgrade', 452 | 'sec-websocket-accept' => $accept, 453 | #'sec-websocket-protocol' => 'chat', 454 | } ); 455 | 456 | ${ $self->{reqcount} }--; 457 | $self->{reqcount} = undef; 458 | 459 | my $create_ws = sub { 460 | my $h = shift; 461 | my $ws = AnyEvent::HTTP::Server::WS->new( 462 | %args, 463 | h => $h, 464 | server => $self->server, 465 | ); 466 | weaken( $self->server->{wss}{ 0+$ws } = $ws ); 467 | 468 | %$self = (); 469 | $cb->($ws); 470 | }; 471 | 472 | if ( $self->handle ) { 473 | $create_ws->($self->handle); 474 | return 475 | } 476 | else { 477 | return HANDLE => $create_ws 478 | } 479 | } 480 | else { 481 | $self->reply(400, '', headers => { 482 | 'sec-websocket-version' => 13, 483 | }); 484 | } 485 | } 486 | 487 | sub send_100_continue { 488 | my ($self,$code,%args) = @_; 489 | my $reply = "HTTP/1.1 100 $http{100}$LF$LF"; 490 | $self->{writer}->( \$reply ); 491 | } 492 | 493 | sub send_headers { 494 | my ($self,$code,%args) = @_; 495 | $code ||= 200; 496 | my $reply = "HTTP/1.1 $code $http{$code}$LF"; 497 | my @good;my @bad; 498 | my $h = { 499 | %{ $args{headers} || {} }, 500 | #'connection' => 'close', 501 | #'connection' => 'keep-alive', 502 | 'connection' => ( $args{headers} && $args{headers}{connection} ) ? $args{headers}{connection} : $self->connection, 503 | }; 504 | if (!exists $h->{'content-length'} and !exists $h->{upgrade}) { 505 | $h->{'transfer-encoding'} = 'chunked'; 506 | $self->{chunked}= 1; 507 | } else { 508 | $self->{chunked}= 0; 509 | } 510 | for (keys %$h) { 511 | if (exists $hdr{lc $_}) { $good[ $hdri{lc $_} ] = $hdr{ lc $_ }.": ".$h->{$_}.$LF; } 512 | else { push @bad, "\u\L$_\E: ".$h->{$_}.$LF; } 513 | } 514 | defined() and $reply .= $_ for @good,@bad; 515 | $reply .= $LF; 516 | $h->{Status} = $code; 517 | $self->attrs->{sent_headers} = $h; 518 | $self->attrs->{head_size} = length $reply; 519 | $self->attrs->{body_size} = 0; 520 | #warn "send headers: $reply"; 521 | $self->{writer}->( \$reply ); 522 | if (!$self->{chunked}) { 523 | if ($args{clearance}) { 524 | $self->{writer} = undef; 525 | } 526 | } 527 | } 528 | 529 | sub body { 530 | my $self = shift; 531 | $self->{chunked} or die "Need to be chunked reply"; 532 | my $content = shift; 533 | utf8::encode $content if utf8::is_utf8 $content; 534 | $self->attrs->{body_size} += length $content; 535 | my $length = sprintf "%x", length $content; 536 | #warn "send body part $length / ".length($content)."\n"; 537 | $self->{writer}->( \("$length$LF$content$LF") ); 538 | } 539 | 540 | sub finish { 541 | my $self = shift; 542 | if ($self->{chunked}) { 543 | # warn "send body end (".$self->connection.")\n"; 544 | if( $self->{writer} ) { 545 | $self->{writer}->( \("0$LF$LF") ); 546 | $self->{writer}->(\undef) if $self->connection eq 'close' or $self->server->{graceful}; 547 | delete $self->{writer}; 548 | } 549 | undef $self->{chunked}; 550 | } 551 | elsif(defined $self->{chunked}) { 552 | # warn "sent body with non-chunked (wr=$self->{writer}) (".$self->connection.")\n"; 553 | if( $self->{writer} ) { 554 | $self->{writer}->(\undef) if $self->connection eq 'close' or $self->server->{graceful}; 555 | delete $self->{writer}; 556 | } 557 | undef $self->{chunked}; 558 | } 559 | else { 560 | die "Need to be chunked reply"; 561 | } 562 | if ( $self->attrs->{sent_headers} ) { 563 | my $h = delete $self->attrs->{sent_headers}; 564 | if( $self->server && $self->server->{on_reply} ) { 565 | $h->{ResponseTime} = AE::now() - $self->reqtime; 566 | $self->server->{on_reply}->( 567 | $self, 568 | $h, 569 | ); 570 | }; 571 | } 572 | } 573 | 574 | sub abort { 575 | my $self = shift; 576 | if( $self->{chunked} ) { 577 | if( $self->{writer} ) { 578 | $self->{writer}->( \("1$LF")); 579 | $self->{writer}->( \undef); 580 | delete $self->{writer}; 581 | } 582 | } 583 | elsif (defined $self->{chunked}) { 584 | undef $self->{chunked}; 585 | } 586 | else { 587 | die "Need to be chunked reply"; 588 | } 589 | if ( $self->attrs->{sent_headers} ) { 590 | my $h = delete $self->attrs->{sent_headers}; 591 | if( $self->server && $self->server->{on_reply} ) { 592 | $h->{ResponseTime} = AE::now() - $self->reqtime; 593 | $h->{SentStatus} = $h->{Status}; 594 | $h->{Status} = "590"; 595 | $self->server->{on_reply}->( 596 | $self, 597 | $h, 598 | ); 599 | }; 600 | } 601 | } 602 | 603 | sub CLEAR {} 604 | sub DESTROY { 605 | my $self = shift; 606 | $self->CLEAR(); 607 | my $caller = "@{[ (caller)[1,2] ]}"; 608 | # warn "Destroy req $self->{method} $self->{uri} by $caller"; 609 | if( $self->{writer} ) { 610 | local $@; 611 | eval { 612 | if ($self->{chunked}) { 613 | $self->abort(); 614 | } else { 615 | if( $self->server && $self->server->{on_not_handled} ) { 616 | $self->server->{on_not_handled}->($self, $caller); 617 | } 618 | if ($self->{writer}) { 619 | $self->reply( 500, "Request not handled\n$self->{method} $self->{uri}\n", headers => { 'content-type' => 'text/plain', NotHandled => 1 } ); 620 | } 621 | } 622 | 1} or do { 623 | warn; 624 | if ($EV::DIED) { 625 | @_ = (); 626 | goto &$EV::DIED; 627 | } else { 628 | warn "[E] Died in request DESTROY: $@ from $caller\n"; 629 | } 630 | }; 631 | } 632 | elsif (defined $self->{chunked}) { 633 | warn "[E] finish or abort was not called for ".( $self->{chunked} ? "chunked" : "partial" )." response"; 634 | $self->abort; 635 | } 636 | if ($self->{reqcount}) { 637 | ${ $self->{reqcount} }--; 638 | } 639 | %$self = (); 640 | } 641 | 642 | 643 | 644 | 1; 645 | 646 | __END__ 647 | 648 | 649 | =head1 SYNOPSIS 650 | 651 | sub dispatch { 652 | my $request = shift; 653 | if ($request->path =~ m{ ^ /ping /? $}x) { 654 | $request->reply( 200, 'pong', headers=> { 'Content-Type' => 'text/plain'}); 655 | } else { 656 | $request->reply( 404, 'Not found', headers=> { 'Content-Type' => 'text/plain'}); 657 | } 658 | } 659 | 660 | =head1 DESCRIPTION 661 | 662 | This module is a part of AnyEvent::HTTP::Server, see perldoc AnyEvent::HTTP::Server for details 663 | 664 | =head1 EXPORT 665 | 666 | Does not export anything 667 | 668 | =head1 SUBROUTINES/METHODS 669 | 670 | =head2 connection - 'Connection' header 671 | 672 | return Connection header from client request 673 | 674 | =head2 method - request method 675 | 676 | return HTTP Method been used in request, such as GET, PUT, HEAD, POST, etc.. 677 | 678 | =head2 full_uri - URI with host part 679 | 680 | Requested uri with host and protocol name. Protocol part is always http:// 681 | 682 | =head2 uri - URI aith host part stripped from it 683 | 684 | Requested uri without host and protocol name 685 | 686 | =head2 headers - Headers from client request 687 | 688 | Return value is a hash reference. All header names are lowercased. 689 | 690 | =head2 go($location) - Send redirect 691 | 692 | Redirect client to $location with 302 HTTP Status code. 693 | 694 | =head2 reply($status,$content, $headers) - Send reply to client 695 | 696 | This method sends both headers and response body to client, and should be called at the end of 697 | request processing. 698 | 699 | Parameters: 700 | 701 | =head3 status 702 | 703 | HTTP Status header (200 is OK, 403 is Auth required and so on). 704 | 705 | =head3 content 706 | 707 | Response body as a scalar. 708 | 709 | =head3 headers 710 | 711 | Response headers as a hash reference. 712 | 713 | =head2 replyjs( [code], $data, %arguments ) - Send reply in JSON format 714 | 715 | =head3 code 716 | 717 | Optional Status code, 200 is default. 718 | 719 | =head3 data 720 | 721 | Response data to encode with JSON. All strings will be encoded as UTF-8. 722 | 723 | =head3 arguments 724 | 725 | List of key=> value arguments. The only supported argument for a moment is 726 | pretty => 1 | 0. JSON data will be formated for easier reading by human, 727 | if pretty is true. 728 | 729 | =head2 send_headers($code, @argumnets_list ) - send response headers to client 730 | 731 | This method may be used in conjunction with body() and finish() methods 732 | for streaming content serving. Response header 'transfer-encoding' is set 733 | to 'chunked' by this method. 734 | 735 | =head3 code 736 | 737 | HTTP Status code to send to a client. 738 | 739 | =head3 arguments_list 740 | 741 | The rest of arguments is interpreted as a key=>value list. One should pass 742 | headers key, for example 743 | 744 | $request->send_headers(200, headers => { 'Content-type' => 'text/plain'} ); 745 | 746 | Subsequent data should be send with body method, and after all data sent, finish 747 | request handling with finish() method. Methods send_headers, body and finish 748 | should be always used together. 749 | 750 | =head2 body($data ) - send chunk of data to client 751 | 752 | Sends part ( or chunk ) of data to client 753 | 754 | =head2 finish - finish chunked request processing 755 | 756 | Finishes request by sending zero-length chunk to client. 757 | 758 | =head2 abort - drop chunked connection 759 | 760 | Let client know if an error occured by dropping connection before sending complete data 761 | 762 | KNOWN ISSUES: nginx, when used as a reverse proxy, masks connection abort, leaving no 763 | ability for browser to detect error condition. 764 | 765 | =cut 766 | 767 | 768 | =head1 RESOURCES 769 | 770 | =over 4 771 | 772 | =item * GitHub repository 773 | 774 | L 775 | 776 | =back 777 | 778 | =head1 ACKNOWLEDGEMENTS 779 | 780 | =over 4 781 | 782 | =item * Thanks to B for L 783 | 784 | =item * Thanks to B for L 785 | 786 | =back 787 | 788 | =head1 AUTHOR 789 | 790 | Mons Anderson, 791 | 792 | =head1 LICENSE 793 | 794 | This program is free software; you can redistribute it and/or modify it 795 | under the terms of either: the GNU General Public License as published 796 | by the Free Software Foundation; or the Artistic License. 797 | 798 | =cut 799 | -------------------------------------------------------------------------------- /lib/AnyEvent/HTTP/Server/WS.pm: -------------------------------------------------------------------------------- 1 | package AnyEvent::HTTP::Server::WS; 2 | 3 | use 5.010; 4 | use AnyEvent::HTTP::Server::Kit; 5 | #use Devel::Hexdump; 6 | #use DDP; 7 | use Config; 8 | use Time::HiRes (); 9 | use JSON::XS; 10 | use Scalar::Util 'weaken'; 11 | 12 | BEGIN { 13 | unless (eval { require DDP;DDP->import(); 1}) { 14 | *p = sub { warn "no DDP for @_"; } 15 | } 16 | } 17 | 18 | our $JSON = JSON::XS->new->utf8->convert_blessed; 19 | 20 | sub time64 () { 21 | int( Time::HiRes::time() * 1e6 ); 22 | } 23 | 24 | sub DEBUG () { 0 } 25 | 26 | use constant { 27 | CONTINUATION => 0, 28 | TEXT => 1, 29 | BINARY => 2, 30 | CLOSE => 8, 31 | PING => 9, 32 | PONG => 10, 33 | 34 | CONNECTING => 1, 35 | OPEN => 2, 36 | CLOSING => 3, 37 | CLOSED => 4, 38 | }; 39 | 40 | our %OP = ( 41 | CONTINUATION() => 'CONT', 42 | TEXT() => 'TEXT', 43 | BINARY() => 'BINR', 44 | CLOSE() => 'CLOS', 45 | PING() => 'PING', 46 | PONG() => 'PONG', 47 | ); 48 | 49 | sub onmessage { 50 | $_[0]{onmessage} = $_[1]; 51 | } 52 | 53 | sub onerror { 54 | $_[0]{onerror} = $_[1]; 55 | } 56 | 57 | sub onclose { 58 | $_[0]{onclose} = $_[1]; 59 | } 60 | 61 | 62 | sub new { 63 | my $pkg = shift; 64 | my %args = @_; 65 | my $h = $args{h}; 66 | my $self = bless { 67 | maxframe => 1024*1024, 68 | mask => 0, 69 | ping_interval => 5, 70 | state => OPEN, 71 | %args, 72 | }, $pkg; 73 | 74 | $self->setup; 75 | return $self; 76 | } 77 | 78 | sub setup { 79 | my $self = shift; 80 | weaken($self); 81 | $self->{h}->on_read(sub { 82 | $self or return; 83 | #say "read".xd( $_[0]{rbuf} ); 84 | while ( my $frame = $self->parse_frame( \$_[0]{rbuf} )) { 85 | #p $frame; 86 | my $op = $frame->[4] || CONTINUATION; 87 | if ($op == PONG) { 88 | if ($self->{ping_id} == $frame->[5]) { 89 | my $now = time64(); 90 | warn sprintf "Received pong for our ping. RTT: %0.6fs\n", ($now - $self->{ping_id})/1e6; 91 | } else { 92 | warn "Not our ping: $frame->[5]"; 93 | } 94 | next; 95 | } 96 | elsif ($op == PING) { 97 | $self->send_frame(1, 0, 0, 0, PONG, $frame->[5]); 98 | next; 99 | } 100 | elsif ($op == CLOSE) { 101 | my ($code,$reason) = unpack 'na*', $frame->[5] if $frame->[5]; 102 | 103 | $self->{onerror} && delete($self->{onerror})->($code,$reason) if $frame->[5]; 104 | 105 | if ( $self->{state} == OPEN ) { 106 | # close was initiated by remote 107 | warn "remote close $code $reason"; 108 | $self->send_frame(1,0,0,0,CLOSE,$frame->[5]); 109 | $self->{state} = CLOSED; 110 | $self->{onclose} && delete($self->{onclose})->({ clean => 1, code => $code, reason => $reason }); 111 | $self or return; 112 | $self->destroy; 113 | return; 114 | } 115 | elsif ( $self->{state} == CLOSING ) { 116 | # close was initiated by us 117 | $self->{close_cb} && delete($self->{close_cb})->(); 118 | $self->{onclose} && delete($self->{onclose})->({ clean => 1, code => $code, reason => $reason }); 119 | $self or return; 120 | $self->destroy; 121 | return; 122 | } 123 | else { 124 | warn "close in wrong state"; 125 | } 126 | 127 | $self->destroy; 128 | last; 129 | } 130 | 131 | 132 | # TODO: fin/!fin, continuation 133 | 134 | #if ( !$frame->[0] ) { 135 | # # TODO: check summary size 136 | # $self->{cont} .= $frame->[5]; 137 | # next; 138 | #} 139 | 140 | 141 | if ( $op == CONTINUATION ) { 142 | $self->{cont} .= $frame->[5]; 143 | next; 144 | } 145 | 146 | my $data = ( delete $self->{cont} ).$frame->[5]; 147 | if ($op == TEXT) { 148 | utf8::decode( $data ); 149 | } 150 | $self->{onmessage} && $self->{onmessage}( 151 | $data, 152 | $op == TEXT ? 'text' : 'binary' 153 | ); 154 | } 155 | }); 156 | $self->{h}->on_error(sub { 157 | $self or return; 158 | warn "h error: @_"; 159 | $self->{onerror} && delete($self->{onerror})->(0,$_[1]); 160 | $self or return; 161 | $self->{onclose} && delete($self->{onclose})->({ clean => 0, data => $_[1] }); 162 | $self or return; 163 | $self->destroy; 164 | }); 165 | $self->{pinger} = AE::timer 0,$self->{ping_interval}, sub { 166 | $self and $self->{h} or return; 167 | $self->{ping_id} = time64(); 168 | $self->send_frame( 1,0,0,0, PING, $self->{ping_id}); 169 | } if $self->{ping_interval} > 0; 170 | return; 171 | } 172 | 173 | sub destroy { 174 | my $self = shift; 175 | $self->{h} and (delete $self->{h})->destroy; 176 | #delete @{$self}{qw(onmessage onerror onclose)}; 177 | #clean all except... 178 | %$self = ( 179 | state => $self->{state} 180 | ); 181 | } 182 | 183 | 184 | sub _xor_mask($$) { 185 | $_[0] ^ 186 | ( 187 | $_[1] x (length($_[0])/length($_[1]) ) 188 | . substr($_[1],0,length($_[0]) % length($_[1])) 189 | ); 190 | } 191 | 192 | sub parse_frame { 193 | my ($self,$rbuf) = @_; 194 | return if length $$rbuf < 2; 195 | my $clone = $$rbuf; 196 | #say "parsing frame: \n".xd "$clone"; 197 | my $head = substr $clone, 0, 2; 198 | my $fin = (vec($head, 0, 8) & 0b10000000) == 0b10000000 ? 1 : 0; 199 | my $rsv1 = (vec($head, 0, 8) & 0b01000000) == 0b01000000 ? 1 : 0; 200 | #warn "RSV1: $rsv1\n" if DEBUG; 201 | my $rsv2 = (vec($head, 0, 8) & 0b00100000) == 0b00100000 ? 1 : 0; 202 | #warn "RSV2: $rsv2\n" if DEBUG; 203 | my $rsv3 = (vec($head, 0, 8) & 0b00010000) == 0b00010000 ? 1 : 0; 204 | #warn "RSV3: $rsv3\n" if DEBUG; 205 | 206 | # Opcode 207 | my $op = vec($head, 0, 8) & 0b00001111; 208 | warn "OPCODE: $op ($OP{$op})\n" if DEBUG; 209 | 210 | # Length 211 | my $len = vec($head, 1, 8) & 0b01111111; 212 | warn "LENGTH: $len\n" if DEBUG; 213 | 214 | # No payload 215 | my $hlen = 2; 216 | if ($len == 0) { warn "NOTHING\n" if DEBUG } 217 | 218 | # Small payload 219 | elsif ($len < 126) { warn "SMALL\n" if DEBUG } 220 | 221 | # Extended payload (16bit) 222 | elsif ($len == 126) { 223 | return unless length $clone > 4; 224 | $hlen = 4; 225 | my $ext = substr $clone, 2, 2; 226 | $len = unpack 'n', $ext; 227 | warn "EXTENDED (16bit): $len\n" if DEBUG; 228 | } 229 | 230 | # Extended payload (64bit) 231 | elsif ($len == 127) { 232 | return unless length $clone > 10; 233 | $hlen = 10; 234 | my $ext = substr $clone, 2, 8; 235 | $len = 236 | $Config{ivsize} > 4 237 | ? unpack('Q>', $ext) 238 | : unpack('N', substr($ext, 4, 4)); 239 | warn "EXTENDED (64bit): $len\n" if DEBUG; 240 | } 241 | 242 | 243 | # TODO !!! 244 | # Check message size 245 | #$self->finish and return if $len > $self->{maxframe}; 246 | 247 | 248 | # Check if whole packet has arrived 249 | my $masked = vec($head, 1, 8) & 0b10000000; 250 | return if length $clone < ($len + $hlen + ($masked ? 4 : 0)); 251 | substr $clone, 0, $hlen, ''; 252 | 253 | # Payload 254 | $len += 4 if $masked; 255 | return if length $clone < $len; 256 | my $payload = $len ? substr($clone, 0, $len, '') : ''; 257 | 258 | # Unmask payload 259 | if ($masked) { 260 | warn "UNMASKING PAYLOAD\n" if DEBUG; 261 | my $mask = substr($payload, 0, 4, ''); 262 | $payload = _xor_mask($payload, $mask); 263 | #say xd $payload; 264 | } 265 | warn "PAYLOAD: $payload\n" if DEBUG; 266 | $$rbuf = $clone; 267 | 268 | return [$fin, $rsv1, $rsv2, $rsv3, $op, $payload]; 269 | } 270 | 271 | sub send_frame { 272 | my ($self, $fin, $rsv1, $rsv2, $rsv3, $op, $payload) = @_; 273 | $self->{h} or return warn "No handle for sending frame"; 274 | warn "BUILDING FRAME\n" if DEBUG; 275 | 276 | # Head 277 | my $frame = 0b00000000; 278 | vec($frame, 0, 8) = $op | 0b10000000 if $fin; 279 | vec($frame, 0, 8) |= 0b01000000 if $rsv1; 280 | vec($frame, 0, 8) |= 0b00100000 if $rsv2; 281 | vec($frame, 0, 8) |= 0b00010000 if $rsv3; 282 | 283 | my $len = length $payload; 284 | # Mask payload 285 | warn "PAYLOAD: $payload\n" if DEBUG; 286 | my $masked = $self->{mask}; 287 | if ($masked) { 288 | warn "MASKING PAYLOAD\n" if DEBUG; 289 | my $mask = pack 'N', int(rand( 2**32 )); 290 | $payload = $mask . _xor_mask($payload, $mask); 291 | } 292 | 293 | # Length 294 | #my $len = length $payload; 295 | #$len -= 4 if $self->{masked}; 296 | 297 | # Empty prefix 298 | my $prefix = 0; 299 | 300 | # Small payload 301 | if ($len < 126) { 302 | vec($prefix, 0, 8) = $masked ? ($len | 0b10000000) : $len; 303 | $frame .= $prefix; 304 | } 305 | 306 | # Extended payload (16bit) 307 | elsif ($len < 65536) { 308 | vec($prefix, 0, 8) = $masked ? (126 | 0b10000000) : 126; 309 | $frame .= $prefix; 310 | $frame .= pack 'n', $len; 311 | } 312 | 313 | # Extended payload (64bit) 314 | else { 315 | vec($prefix, 0, 8) = $masked ? (127 | 0b10000000) : 127; 316 | $frame .= $prefix; 317 | $frame .= 318 | $Config{ivsize} > 4 319 | ? pack('Q>', $len) 320 | : pack('NN', $len >> 32, $len & 0xFFFFFFFF); 321 | } 322 | 323 | if (DEBUG) { 324 | warn 'HEAD: ', unpack('B*', $frame), "\n"; 325 | warn "OPCODE: $op\n"; 326 | } 327 | 328 | # Payload 329 | $frame .= $payload; 330 | print "Built frame = \n".xd( "$frame" ) if DEBUG; 331 | 332 | $self->{h}->push_write( $frame ); 333 | return; 334 | } 335 | 336 | sub send : method { 337 | my $self = shift; 338 | my $data = shift; 339 | my $is_text; 340 | if (ref $data) { 341 | $is_text = 1; 342 | $data = $JSON->encode($data); 343 | } 344 | elsif ( utf8::is_utf8($data) ) { 345 | if ( utf8::downgrade($data,1) ) { 346 | 347 | } 348 | else { 349 | $is_text = 1; 350 | utf8::encode($data); 351 | } 352 | } 353 | $self->send_frame(1, 0, 0, 0, ($is_text ? TEXT : BINARY ), $data); 354 | } 355 | 356 | sub close : method { 357 | =for rem 358 | 1000 359 | 360 | 1000 indicates a normal closure, meaning that the purpose for 361 | which the connection was established has been fulfilled. 362 | =cut 363 | my $self = shift; 364 | my $cb = pop; 365 | my $code = shift // 1000; 366 | my $msg = shift; 367 | if ($self->{state} == OPEN) { 368 | $self->send_frame(1,0,0,0,CLOSE,pack("na*",$code,$msg)); 369 | $self->{state} = CLOSING; 370 | $self->{close_cb} = shift; 371 | } 372 | elsif ($self->{state} == CLOSING) { 373 | return; 374 | } 375 | elsif ($self->{state} == CLOSED) { 376 | warn "called close, while already closed from @{[ (caller)[1,2] ]}"; 377 | } 378 | else { 379 | warn "close not possible in state $self->{state} from @{[ (caller)[1,2] ]}"; 380 | } 381 | } 382 | 383 | sub DESTROY { 384 | my $self = shift; 385 | my $caller = "@{[ (caller)[1,2] ]}"; 386 | if ($self->{h} and $self->{state} != CLOSED) { 387 | warn "initiate close by DESTROY"; 388 | my $copy = bless {%$self}, 'AnyEvent::HTTP::Server::WS::CLOSING'; 389 | $copy->close(sub { 390 | warn "closed"; 391 | undef $copy; 392 | }); 393 | } 394 | #warn "Destroy ws $self by $caller"; 395 | delete $self->{server}{wss}{ 0+$self }; 396 | %$self = (); 397 | } 398 | 399 | package AnyEvent::HTTP::Server::WS::CLOSING; 400 | 401 | our @ISA = qw(AnyEvent::HTTP::Server::WS); 402 | 403 | sub DESTROY { 404 | 405 | } 406 | 407 | 1; 408 | -------------------------------------------------------------------------------- /makeall.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | MODULE=`perl -ne 'print($1),exit if m{version_from.+?([\w/.]+)}i' Makefile.PL`; 4 | perl=perl 5 | $perl -v 6 | 7 | rm -rf MANIFEST.bak Makefile.old MYMETA.* META.* && \ 8 | pod2text $MODULE > README && \ 9 | $perl -i -lpne 's{^\s+$}{};s{^ ((?: {8})+)}{" "x(4+length($1)/2)}se;' README && \ 10 | AUTHOR=1 $perl Makefile.PL && \ 11 | make manifest && \ 12 | cp MYMETA.yml META.yml && \ 13 | cp MYMETA.json META.json && \ 14 | make && \ 15 | make disttest && \ 16 | make dist && \ 17 | cp -f *.tar.gz dist/ && \ 18 | make clean && \ 19 | cp META.yml MYMETA.yml && \ 20 | cp META.json MYMETA.json && \ 21 | rm -rf MANIFEST.bak Makefile.old && \ 22 | echo "All is OK" 23 | -------------------------------------------------------------------------------- /t/00-load.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use Test::More tests => 1; 4 | 5 | BEGIN { 6 | use_ok( 'AnyEvent::HTTP::Server' ) 7 | } 8 | 9 | diag( "Testing AnyEvent::HTTP::Server $AnyEvent::HTTP::Server::VERSION, AnyEvent $AnyEvent::VERSION, Perl $], $^X" ); 10 | -------------------------------------------------------------------------------- /t/01-basic-ae.t: -------------------------------------------------------------------------------- 1 | #use strict; 2 | #use uni::perl ':dumper'; 3 | 4 | use AnyEvent::Socket; 5 | use AnyEvent::Handle; 6 | use AnyEvent::HTTP::Server; 7 | use AnyEvent::HTTP::Server::Kit ':dumper'; 8 | use AnyEvent::Loop; 9 | use FindBin; 10 | 11 | do "$FindBin::Bin/basic.pl" or die "$FindBin::Bin/basic.pl: ".($@ ? $@ : $!); 12 | -------------------------------------------------------------------------------- /t/02-basic-ev.t: -------------------------------------------------------------------------------- 1 | #use strict; 2 | #use uni::perl ':dumper'; 3 | 4 | use AnyEvent::Socket; 5 | use AnyEvent::Handle; 6 | use AnyEvent::HTTP::Server; 7 | use AnyEvent::HTTP::Server::Kit ':dumper'; 8 | use Test::More; 9 | BEGIN{ 10 | eval { require EV; 1 } or plan skip_all => "EV not installed"; 11 | } 12 | use FindBin; 13 | 14 | do "$FindBin::Bin/basic.pl" or die "$FindBin::Bin/basic.pl: $!"; 15 | -------------------------------------------------------------------------------- /t/03-sendfile.t: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | #use lib::abs '../blib/lib', '..'; 5 | use t::testlib; 6 | use AnyEvent::HTTP::Server::Kit; 7 | 8 | use Test::More; 9 | 10 | my $file = __FILE__; 11 | my $data = do { open my $f, '<', $file or die "$!"; local $/; <$f> }; 12 | 13 | our $PARTIAL; 14 | sub ALL () { 1 } 15 | 16 | test_server { 17 | my $s = shift; 18 | my $r = shift; 19 | diag "sending file $file"; 20 | $r->sendfile(200, $file, headers => { 'content-type' => 'application/perl' }); 21 | return; 22 | } 'test1', 23 | [["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200, { 'content-type' => 'application/perl' }, $data ], 24 | if ALL; 25 | 26 | done_testing(); 27 | -------------------------------------------------------------------------------- /t/basic.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use Test::More tests => 224; 4 | use Data::Dumper; 5 | use FindBin; 6 | use lib "$FindBin::Bin/.."; 7 | $Data::Dumper::Useqq = 1; 8 | 9 | use t::testlib; 10 | 11 | use constant { 12 | CHUNKED => 1, 13 | ALL => 1, 14 | }; 15 | 16 | our $PARTIAL; 17 | 18 | my $bad = '\x'x1024; 19 | my $bad_unescaped = 'x'x1024; 20 | 21 | # The tests 22 | 23 | for $PARTIAL (0, 1) { 24 | 25 | test_server_close { return 200,'ok' } 'skip empty lines', 26 | [["\n\nGET /test1 HTTP/1.1\nHost:localhost\nConnection:close\n\n"], 200, { connection => 'close' }, 'ok' ], 27 | if ALL; 28 | 29 | test_server { return 200,'ok' } { max_header_size => 1024, read_size => 1024 }, 'reset too large', 30 | [["GET /test1 HTTP/1.1\nHost:" .("x"x2048). "\nConnection:keep-alive\n\n"], 413, { connection => 'close' }, qr/Request Entity Too Large/ ], 31 | if ALL; 32 | 33 | test_server { return 200,'ok' } 'reset bad request', 34 | [["GET /test1 HTTP/1\nHost:localhost\nConnection:keep-alive\n\n"], 400, { connection => 'close' }, qr/Bad Request/ ], 35 | if ALL; 36 | 37 | test_server { 38 | my $s = shift; 39 | my $r = shift; 40 | return ( 41 | $r->method eq 'GET' ? 200 : 400, 42 | "$r->[0]:$r->[1]:$r->[2]{host}".$r->headers->{'x-t+q'}, 43 | headers => { 44 | 'content-type' => 'text/plain', 45 | 'x-test' => $s->{__seq}, 46 | }, 47 | ); 48 | } 'immediate', 49 | [["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200, { 'x-test' => 1 }, "GET:/test1:localhost" ], 50 | [["GET /test2 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200, { 'x-test' => 2 }, "GET:/test2:localhost" ], 51 | [["METHOD /test3 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nContent-Length:4\n\ntest"], 400, { 'x-test' => 3 }, "METHOD:/test3:localhost" ], 52 | [["GET /test4 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nX-t: x; q=\"$bad\"\n\n"], 200, { 'x-test' => 4 }, "GET:/test4:localhost$bad_unescaped" ], 53 | if ALL; 54 | 55 | test_server { 56 | my $s = shift; 57 | my $r = shift; 58 | return ( 59 | $r->method eq 'GET' ? 200 : 400, 60 | "$r->[0]:$r->[1]:$r->[2]{host}:".$r->headers->{accept}.':'.$r->headers->{'accept+q'}, 61 | headers => { 62 | 'content-type' => 'text/plain', 63 | 'x-test' => $s->{__seq}, 64 | }, 65 | ); 66 | } 'by sub', 67 | [[qq{GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nAccept:*/*\n\t;q="\\"1\\"!=2"\n\n}], 200, { 'x-test' => 1 }, q{GET:/test1:localhost:*/* ;q="\"1\"!=2":"1"!=2} ], # " 68 | [[qq{GET /test2 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nAccept:*/*; q="1\\!=2"\n\n}], 200, { 'x-test' => 2 }, q{GET:/test2:localhost:*/*; q="1\\!=2":1!=2} ], # " 69 | [[qq{GET /test3 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nAccept:*/*; q="1\n\t2"\n\n}], 200, { 'x-test' => 3 }, q{GET:/test3:localhost:*/*; q="1 2":1 2} ], # " 70 | [[qq{GET /test4 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nAccept:*/*;\n\t q="1 2"\n\n}], 200, { 'x-test' => 4 }, q{GET:/test4:localhost:*/*; q="1 2":1 2} ], # " 71 | [["GET /test5 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200, { 'x-test' => 5 }, "GET:/test5:localhost::" ], 72 | [["METHOD /test6 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nContent-Length:4\n\ntest"], 400, { 'x-test' => 6 }, "METHOD:/test6:localhost::" ], 73 | [[qq{GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nAccept:*/*\n\t;q=123\n\n}], 200, { 'x-test' => 7 }, q{GET:/test1:localhost:*/* ;q=123:123} ], # " 74 | [[qq{GET /test7 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nAccept:*/*;\n\t q="$bad"\n\n}], 200, { 'x-test' => 8 }, qq{GET:/test7:localhost:*/*; q="$bad":$bad_unescaped} ], # " 75 | if ALL; 76 | 77 | test_server { 78 | my $s = shift; 79 | my $r = shift; 80 | my $replybody = "$r->[0]:$r->[1]:$r->[2]{host}"; 81 | return sub { 82 | my ($last,$body) = @_; 83 | #diag explain "$last:$body"; 84 | if ($body) { 85 | $replybody .= ':'.length($$body).':'.$$body; 86 | } 87 | if ($last) { 88 | $r->reply( 89 | $r->method eq 'GET' ? 200 : 400, 90 | $replybody, 91 | headers => { 92 | 'content-type' => 'text/plain', 93 | 'x-test' => $s->{__seq}, 94 | }, 95 | ); 96 | } 97 | } 98 | } 'read body', 99 | [["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200, { 'x-test' => 1 }, "GET:/test1:localhost:0:",'' ], 100 | [["GET /test2 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200, { 'x-test' => 2 }, "GET:/test2:localhost:0:",'' ], 101 | [["METHOD /test3 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nContent-Length:4\n\ntest"], 400, { 'x-test' => 3 }, "METHOD:/test3:localhost", $PARTIAL ? ":1:t:1:e:1:s:1:t" : ':4:test' ], 102 | if ALL; 103 | 104 | 105 | test_server { 106 | my $s = shift; 107 | my $r = shift; 108 | my $replybody = "$r->[0]:$r->[1]:$r->[2]{host}"; 109 | my @reply = split //, $replybody; 110 | my $t;$t = AE::timer 0,0.01, sub { 111 | if (@reply) { 112 | $r->body(shift @reply); 113 | } else { 114 | undef $t; 115 | $r->finish; 116 | } 117 | }; 118 | $r->send_headers( 119 | $r->method eq 'GET' ? 200 : 400, 120 | headers => { 121 | 'content-type' => 'text/plain', 122 | 'x-test' => $s->{__seq}, 123 | }, 124 | ); 125 | return; 126 | } 'chunked', 127 | [["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200, { 'x-test' => 1 }, "GET:/test1:localhost",'' ], 128 | [["GET /test2 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200, { 'x-test' => 2 }, "GET:/test2:localhost",'' ], 129 | [["METHOD /test3 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nContent-Length:4\n\ntest"], 400, { 'x-test' => 3 }, "METHOD:/test3:localhost", '' ], 130 | if ALL or CHUNKED; 131 | 132 | 133 | test_server { 134 | my $s = shift; 135 | my $r = shift; 136 | my $replybody = "$r->[0]:$r->[2]{host}:".$r->path.':'.$r->param("query").':'.join(',',sort $r->param); 137 | return ( 138 | 200, 139 | $replybody 140 | ); 141 | } 'query', 142 | [["GET /test1?query=10+1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200,{}, "GET:localhost:/test1:10 1:query",'' ], 143 | [["GET https://test:80/test2/3?query=10%201 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200,{}, "GET:localhost:/test2/3:10 1:query",'' ], 144 | [["GET //test/test3?query= HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200,{}, "GET:localhost:/test3::query",'' ], 145 | [["GET /test4?a=%20&b=%25 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200,{}, "GET:localhost:/test4::a,b",'' ], 146 | if ALL; 147 | 148 | my $formdata = "a=%20&b=%25"; 149 | my $LF = "\015\012"; 150 | my $mpart = q{ 151 | --Test 152 | Content-Disposition: form-data; name="Part1"; key="MyKey" 153 | 154 | Part1Content 155 | --Test 156 | Content-Disposition: form-data; name="Part2" 157 | Content-Transfer-Encoding: quoted-printable 158 | 159 | =?UTF-8?Q?=74=65=73=74?= 160 | --Test 161 | Content-Disposition: form-data; name="Part3"; 162 | filename="some-image.jpg" 163 | Content-Type: image/jpeg 164 | Content-Transfer-Encoding: base64 165 | 166 | dGVzdA== 167 | --Test 168 | }; 169 | 170 | =for 171 | =cut 172 | 173 | ( my $mpart2 = $mpart ) =~ s{\015?\012}{\015\012}sg; 174 | 175 | test_server { 176 | my $s = shift; 177 | my $r = shift; 178 | my $replybody = $r->method.':'.$r->path; 179 | # form-data 180 | # form-url 181 | # raw 182 | my $rr = $r; 183 | return { 184 | raw => sub { 185 | warn "raw: ".explain \@_; 186 | $r->reply( 187 | 200, 188 | $replybody 189 | ); 190 | }, 191 | multipart => sub { 192 | my ($last,$part,$hd) = @_; 193 | $rr; 194 | #warn Dumper $part, $hd; 195 | #diag explain $hd; 196 | $replybody .= ':'.( utf8::is_utf8($part) ? 'u' : 'a' ); 197 | utf8::encode($part) if utf8::is_utf8($part); 198 | $replybody .= ':'.$hd->{name}.':'.$hd->{filename}.':'.$part; 199 | if ($last) { 200 | $r->reply( 201 | 200, 202 | $replybody 203 | ); 204 | }; 205 | }, 206 | form => sub { 207 | my ($form,$rawbody) = @_; 208 | $r->reply( 209 | 200, 210 | $r->method.':'.$r->path.':'.join('&', map { $_.'='.$form->{$_} } sort keys %$form ) 211 | ); 212 | #diag explain \@_; 213 | }, 214 | }; 215 | } 'multipart', 216 | [["POST /test1?query=10+1 HTTP/1.1\nHost:localhost\nContent-type:application/x-www-form-urlencoded\nConnection:keep-alive\nContent-Length:".length($formdata)."\n\n$formdata"], 217 | 200, {}, "POST:/test1:a= &b=%",'' ], 218 | [["POST /test2 HTTP/1.1\nHost:localhost\nContent-type:multipart/form-data; boundary=Test\nConnection:keep-alive\nContent-Length:".length($mpart)."\n\n$mpart"], 219 | 200, {}, "POST:/test2:a:Part1::Part1Content:u:Part2::test:a:Part3:some-image.jpg:test",'' ], 220 | [[qq{POST /test2 HTTP/1.1\nHost:localhost\nContent-type:multipart/form-data; boundary="Test"\nConnection:keep-alive\nContent-Length:}.length($mpart)."\n\n$mpart"], 221 | 200, {}, "POST:/test2:a:Part1::Part1Content:u:Part2::test:a:Part3:some-image.jpg:test",'' ], 222 | [["POST /test2 HTTP/1.1\nHost:localhost\nContent-type:multipart/form-data; boundary=Test\nConnection:keep-alive\nContent-Length:".length($mpart2)."\n\n$mpart2"], 223 | 200, {}, "POST:/test2:a:Part1::Part1Content:u:Part2::test:a:Part3:some-image.jpg:test",'' ], 224 | [[qq{POST /test2 HTTP/1.1\nHost:localhost\nContent-type:multipart/form-data; boundary="Test"\nConnection:keep-alive\nContent-Length:}.length($mpart2)."\n\n$mpart2"], 225 | 200, {}, "POST:/test2:a:Part1::Part1Content:u:Part2::test:a:Part3:some-image.jpg:test",'' ], 226 | # [["GET /test HTTP/1.1\nConnection:close\n\n"], 200,{}, "GET:/test",'' ], 227 | # [["GET /test HTTP/1.1\nConnection:close\n\n"], 200,{}, "GET:/test",'' ], 228 | if ALL; 229 | 230 | #( 231 | # qq{Header: test\n\t;\n\tfield=value}, 232 | # qq{Header: test;\n field1="value1 +"\n ;field2=\n value2}, 233 | #) 234 | 235 | test_server { 236 | my $s = shift; 237 | my $r = shift; 238 | return; 239 | } 'overlap', 240 | [["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 500, {}, "Request not handled\nGET /test1\n" ], 241 | [["GET /test2 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\nGET"], 500, {}, "Request not handled\nGET /test2\n" ], 242 | [[" /test3 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 500, {}, "Request not handled\nGET /test3\n" ], 243 | [["POST /test4 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nContent-Length:4\n\ntestPOST"], 500, {}, "Request not handled\nPOST /test4\n",'' ], 244 | [[" /test5 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nContent-Length:4\n\ntest"], 500, {}, "Request not handled\nPOST /test5\n",'' ], 245 | [["POST /test6 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nContent-Length:4\n\nte","st"], 500, {}, "Request not handled\nPOST /test6\n",'' ], 246 | # [["GET /test2 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200, { 'x-test' => 2 }, "GET:/test2:localhost" ], 247 | # [["METHOD /test3 HTTP/1.1\nHost:localhost\nConnection:keep-alive\nContent-Length:4\n\ntest"], 400, { 'x-test' => 3 }, "METHOD:/test3:localhost" ], 248 | if ALL; 249 | 250 | test_server_close { 251 | my $s = shift; 252 | my $r = shift; 253 | return; 254 | } 'connection close', 255 | [["GET /test1 HTTP/1.1\nHost:localhost\nConnection:close\n\n"], 500, {}, "Request not handled\nGET /test1\n" ], 256 | if ALL; 257 | 258 | test_server { 259 | return 204, undef, headers => {}; 260 | } '204 - no cl - undef', 261 | [["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 204, { 'content-length' => undef }, "" ], 262 | if ALL; 263 | 264 | test_server { 265 | return 204, "", headers => {}; 266 | } '204 - no cl - empty', 267 | [["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 204, { 'content-length' => undef }, "" ], 268 | if ALL; 269 | 270 | test_server { 271 | my $s = shift; 272 | my $r = shift; 273 | return 204, "some content", headers => {}; 274 | } '204 - with content', 275 | [["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 204, { 'content-length' => undef }, "" ], 276 | if ALL; 277 | 278 | test_server { 279 | my $s = shift; 280 | my $r = shift; 281 | return 204, "", headers => {'content-length' => 0}; 282 | } '204 - with header', 283 | [["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 204, { 'content-length' => undef }, "" ], 284 | if ALL; 285 | 286 | test_server { 287 | my $s = shift; 288 | my $r = shift; 289 | return 200, undef; 290 | } '200 - with undef body', 291 | [["GET /test1 HTTP/1.1\nHost:localhost\nConnection:keep-alive\n\n"], 200, { 'content-length' => 0 }, "" ], 292 | if ALL; 293 | 294 | } 295 | 296 | done_testing(); 297 | -------------------------------------------------------------------------------- /t/pod.t: -------------------------------------------------------------------------------- 1 | #!perl -T 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | # Ensure a recent version of Test::Pod 8 | my $min_tp = 1.22; 9 | eval "use Test::Pod $min_tp"; 10 | plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; 11 | 12 | all_pod_files_ok(); 13 | -------------------------------------------------------------------------------- /t/testlib.pm: -------------------------------------------------------------------------------- 1 | package t::testlib; 2 | 3 | use AnyEvent::HTTP::Server::Kit ':dumper'; 4 | 5 | use Test::More; 6 | use AnyEvent::Socket; 7 | use AnyEvent::Handle; 8 | 9 | use AnyEvent::HTTP::Server; 10 | 11 | our @EXPORT = qw(test_server test_server_close); 12 | sub import { no strict 'refs'; 13 | my $self = shift; my $caller = caller; 14 | defined &$_ 15 | ? *{ $caller.'::'.$_ } = \&$_ 16 | : croak "$_ not exported by $self" 17 | for (@_ ? @_ : @EXPORT); 18 | } 19 | 20 | sub read_response { 21 | my $h = shift; 22 | my $cb = pop; 23 | my %h; 24 | delete $h->{_skip_drain_rbuf} if $h->{_eof}; 25 | $h->push_read(line => sub { 26 | shift; 27 | diag "@_"; 28 | $_[0] =~ /^HTTP\/([0-9\.]+) \s+ ([0-9]{3}) (?: \s+ ([^\015\012]*) )?/ixo 29 | or return $cb->( undef, "Invalid server response ($_[0])" ); 30 | $h{''} = [ $1,$2,$3 ]; 31 | 32 | my $hd;$hd = sub { 33 | $h->push_read(line => sub { 34 | shift; 35 | if ($_[0]) { 36 | #warn "got header @_"; 37 | my ($k,$v) = split /\s*:\s*/,$_[0],2; 38 | $k = lc $k; 39 | $h{$k} = exists $h{$k} ? $h{$k}.';'.$v : $v; 40 | $hd->(); 41 | } else { 42 | #warn "no more"; 43 | if ( $h{ 'content-length' } ) { 44 | $h->push_read(chunk => $h{ 'content-length' }, sub { 45 | $h->on_error(sub { diag "Error '$_[2]' after reading response" }); 46 | $cb->(\%h, $_[1]); 47 | }); 48 | } 49 | elsif ($h{'transfer-encoding'} eq 'chunked') { 50 | my @chunks; 51 | my $reader;$reader = sub { 52 | $h->push_read(line => sub { shift; 53 | my $length = hex(shift); 54 | #warn "Chunk $length"; 55 | if ($length) { 56 | $h->push_read( chunk => $length + 2, sub { 57 | shift; 58 | substr( $_[0], -2,2,"" ); # chomp CRLF 59 | #substr( $_[0], -1,1,"" ) if substr($_[0], -1,1) eq "\015"; # chomp CR 60 | push @chunks, $_[0]; 61 | $reader->(); 62 | } ); 63 | } else { 64 | #warn dumper \@chunks; 65 | $h->push_read( chunk => 2, sub { 66 | $h->on_error(sub { diag "Error '$_[2]' after reading response" }); 67 | $cb->(\%h,@chunks); 68 | }); 69 | } 70 | }); 71 | }; 72 | $reader->(); 73 | } 74 | else { 75 | $cb->(\%h); 76 | } 77 | } 78 | }); 79 | };$hd->(); 80 | }); 81 | } 82 | 83 | sub send_request($@&) { 84 | my $h = shift; 85 | my $cb = pop; 86 | my @parts = @_; 87 | if (@parts == 1) { 88 | @parts = split //,$parts[0]; 89 | } 90 | my $total = join '', @parts; 91 | diag substr($total, 0, index($total,"\n")); 92 | my $t; 93 | my $send; 94 | my $on_error = $h->{on_error}; 95 | $h->on_error(sub{ 96 | my $h = shift; 97 | undef $send; 98 | undef $t; 99 | if (not length $h->{rbuf}) { 100 | $h->destroy; 101 | $cb->({ Error => "$_[1]" }); 102 | return; 103 | } 104 | $h->on_error($on_error); 105 | read_response($h,$cb); 106 | }); 107 | if (!$::PARTIAL) { 108 | $h->push_write(join '', @parts); 109 | $h->on_error($on_error); 110 | read_response($h,$cb); 111 | return; 112 | } 113 | $send = sub { 114 | if (@parts) { 115 | $h->push_write(shift @parts); 116 | $t = AE::timer 0.0005,0,sub { 117 | return unless $send; 118 | undef $t; 119 | $send->(); 120 | }; 121 | } else { 122 | $h->on_error($on_error); 123 | read_response($h,$cb); 124 | } 125 | }; 126 | $send->(); 127 | } 128 | 129 | sub connect_handle($&) { 130 | my ($port,$cb) = @_; 131 | tcp_connect 0,$port, sub { 132 | my $fh = shift or return warn "$!"; 133 | my $h = AnyEvent::Handle->new( 134 | fh => $fh, 135 | on_error => sub { warn "error: @_" }, 136 | on_eof => sub { warn "error: @_" }, 137 | on_read => sub { 1 }, 138 | ); 139 | $cb->($h); 140 | }; 141 | } 142 | 143 | sub test_server (&@) { 144 | my $server_callback = shift; 145 | my ($opts,$name); 146 | while (@_ and ref $_[0] ne 'ARRAY') { 147 | if (ref $_[0] eq 'HASH') { 148 | $opts = shift; 149 | } 150 | elsif (!ref $_[0]) { 151 | $name = shift; 152 | } 153 | else { 154 | Carp::croak "Bad options"; 155 | } 156 | } 157 | $name = ( $::PARTIAL ? 'partial' : 'complete' )." - $name"; 158 | my @tests = @_; 159 | my $cv = AE::cv; 160 | my $s;$s = AnyEvent::HTTP::Server->new( %$opts, port => undef, cb => sub { 161 | $s or return; 162 | my $seq = ++$s->{__seq}; 163 | my $r = $_[0]; 164 | diag "request $seq. ".$r->method.' '.$r->uri; 165 | $server_callback->($s,@_); 166 | } ); 167 | my ($host,$port) = $s->listen(); 168 | $s->accept(); 169 | 170 | connect_handle $port, sub { 171 | my $h = shift; 172 | my $idx = 0; 173 | my $rq;$rq = sub { 174 | return undef $h, $s->destroy, $cv->send unless @tests; 175 | ++$idx; 176 | my ($req,$rescode,$resh,$resb, $morebody) = @{ shift @tests }; 177 | #diag "send request:\n@$req"; 178 | send_request( $h,@$req,sub { 179 | my $h = shift; 180 | my $b = join '', @_; 181 | #my ($h,$b) = @_; 182 | #diag explain \@_; 183 | is $h->{''}[1], $rescode, "$name $idx - reply status ok"; 184 | is $h->{$_},$resh->{$_}, "$name $idx - reply header $_ ok" for (keys %$resh); 185 | if (UNIVERSAL::isa($resb, 'Regexp')) { 186 | like $b,$resb, "$name $idx - reply body like ok" or diag explain $h,$b; 187 | } else { 188 | is $b,$resb.$morebody, "$name $idx - reply body ok" or diag explain $h,$b, do { 189 | $Data::Dumper::Useqq=1; 190 | diag dumper $b; 191 | diag dumper $resb.$morebody; 192 | }; 193 | } 194 | 195 | $rq->(); 196 | }); 197 | }; 198 | $rq->(); 199 | }; 200 | $cv->recv; 201 | } 202 | 203 | sub test_server_close (&@) { 204 | my $server_callback = shift; 205 | my ($opts,$name); 206 | while (@_ and ref $_[0] ne 'ARRAY') { 207 | if (ref $_[0] eq 'HASH') { 208 | $opts = shift; 209 | } 210 | elsif (!ref $_[0]) { 211 | $name = shift; 212 | } 213 | else { 214 | Carp::croak "Bad options"; 215 | } 216 | } 217 | my @tests = @_; 218 | my $cv = AE::cv; 219 | my $s;$s = AnyEvent::HTTP::Server->new( %$opts, port => undef, cb => sub { 220 | $s or return; 221 | my $seq = ++$s->{__seq}; 222 | my $r = $_[0]; 223 | diag "request $seq. ".$r->method.' '.$r->uri; 224 | $server_callback->($s,@_); 225 | } ); 226 | my ($host,$port) = $s->listen(); 227 | $s->accept(); 228 | 229 | connect_handle $port, sub { 230 | my $h = shift; 231 | my $wait; 232 | my $end = sub { 233 | undef $h; 234 | $s->destroy; 235 | undef $wait; 236 | $cv->send; 237 | }; 238 | 239 | $h->on_eof(sub { 240 | pass "$name - connection closed"; 241 | $end->(); 242 | }); 243 | 244 | my $rq;$rq = sub { 245 | unless(@tests) { 246 | $h->on_read(sub { 247 | fail "$name - received unwaited data"; 248 | diag $h->{rbuf}; 249 | $end->(); 250 | }); 251 | $wait = AE::timer 1,0,sub { 252 | fail "$name - connection not closed"; 253 | $end->(); 254 | }; 255 | return; 256 | }; 257 | my ($req,$rescode,$resh,$resb, $morebody) = @{ shift @tests }; 258 | #diag "send request:\n@$req"; 259 | send_request( $h,@$req,sub { 260 | my $h = shift; 261 | my $b = join '', @_; 262 | #my ($h,$b) = @_; 263 | #diag explain \@_; 264 | is $h->{''}[1], $rescode, "$name - reply status ok"; 265 | is $h->{$_},$resh->{$_}, "$name - reply header $_ ok" for (keys %$resh); 266 | is $b,$resb.$morebody, "$name - reply body ok" or diag explain $h,$b; 267 | $rq->(); 268 | }); 269 | }; 270 | $rq->(); 271 | }; 272 | $cv->recv; 273 | } 274 | --------------------------------------------------------------------------------