libanyevent-httpd-perl-0.93/ 0000755 0001750 0001750 00000000000 11616455751 015015 5 ustar dimka dimka libanyevent-httpd-perl-0.93/README 0000644 0001750 0001750 00000025402 11616455751 015700 0 ustar dimka dimka NAME
AnyEvent::HTTPD - A simple lightweight event based web (application)
server
VERSION
Version 0.93
SYNOPSIS
use AnyEvent::HTTPD;
my $httpd = AnyEvent::HTTPD->new (port => 9090);
$httpd->reg_cb (
'/' => sub {
my ($httpd, $req) = @_;
$req->respond ({ content => ['text/html',
"Hello World!
"
. "another test page"
. ""
]});
},
'/test' => sub {
my ($httpd, $req) = @_;
$req->respond ({ content => ['text/html',
"Test page
"
. "Back to the main page"
. ""
]});
},
);
$httpd->run; # making a AnyEvent condition variable would also work
DESCRIPTION
This module provides a simple HTTPD for serving simple web application
interfaces. It's completly event based and independend from any event
loop by using the AnyEvent module.
It's HTTP implementation is a bit hacky, so before using this module
make sure it works for you and the expected deployment. Feel free to
improve the HTTP support and send in patches!
The documentation is currently only the source code, but next versions
of this module will be better documented hopefully. See also the
"samples/" directory in the AnyEvent::HTTPD distribution for basic
starting points.
FEATURES
* support for GET and POST requests.
* support for HTTP 1.0 keep-alive.
* processing of "x-www-form-urlencoded" and "multipart/form-data"
("multipart/mixed") encoded form parameters.
* support for streaming responses.
* with version 0.8 no more dependend on LWP for HTTP::Date.
* (limited) support for SSL
METHODS
The AnyEvent::HTTPD class inherits directly from
AnyEvent::HTTPD::HTTPServer which inherits the event callback interface
from Object::Event.
Event callbacks can be registered via the Object::Event API (see the
documentation of Object::Event for details).
For a list of available events see below in the *EVENTS* section.
new (%args)
This is the constructor for a AnyEvent::HTTPD object. The %args hash
may contain one of these key/value pairs:
host => $host
The TCP address of the HTTP server will listen on. Usually
0.0.0.0 (the default), for a public server, or 127.0.0.1 for a
local server.
port => $port
The TCP port the HTTP server will listen on. If undefined some
free port will be used. You can get it via the "port" method.
ssl => $tls_ctx
If this option is given the server will listen for a SSL/TLS
connection on the configured port. As $tls_ctx you can pass
anything that you can pass as "tls_ctx" to an AnyEvent::Handle
object.
Example:
my $httpd =
AnyEvent::HTTPD->new (
port => 443,
ssl => { cert_file => "/path/to/my/server_cert_and_key.pem" }
);
Or:
my $httpd =
AnyEvent::HTTPD->new (
port => 443,
ssl => AnyEvent::TLS->new (...),
);
request_timeout => $seconds
This will set the request timeout for connections. The default
value is 60 seconds.
backlog => $int
The backlog argument defines the maximum length the queue of
pending connections may grow to. The real maximum queue length
will be 1.5 times more than the value specified in the backlog
argument.
See also "man 2 listen".
By default will be set by AnyEvent::Socket"::tcp_server" to 128.
connection_class => $class
This is a special parameter that you can use to pass your own
connection class to AnyEvent::HTTPD::HTTPServer. This is only of
interest to you if you plan to subclass
AnyEvent::HTTPD::HTTPConnection.
request_class => $class
This is a special parameter that you can use to pass your own
request class to AnyEvent::HTTPD. This is only of interest to
you if you plan to subclass AnyEvent::HTTPD::Request.
allowed_methods => $arrayref
This parameter sets the allowed HTTP methods for requests,
defaulting to GET, HEAD and POST. Each request received is
matched against this list, and a '501 not implemented' is
returned if no match is found. Requests using disallowed
handlers will never trigger callbacks.
port
Returns the port number this server is bound to.
host
Returns the host/ip this server is bound to.
allowed_methods
Returns an arrayref of allowed HTTP methods, possibly as set by the
allowed_methods argument to the constructor.
stop_request
When the server walks the request URI path upwards you can stop the
walk by calling this method. You can even stop further handling
after the "request" event.
Example:
$httpd->reg_cb (
'/test' => sub {
my ($httpd, $req) = @_;
# ...
$httpd->stop_request; # will prevent that the callback below is called
},
'' => sub { # this one wont be called by a request to '/test'
my ($httpd, $req) = @_;
# ...
}
);
run This method is a simplification of the "AnyEvent" condition variable
idiom. You can use it instead of writing:
my $cvar = AnyEvent->condvar;
$cvar->wait;
stop
This will stop the HTTP server and return from the "run" method if
you started the server via that method!
EVENTS
Every request goes to a specific URL. After a (GET or POST) request is
received the URL's path segments are walked down and for each segment a
event is generated. An example:
If the URL '/test/bla.jpg' is requestes following events will be
generated:
'/test/bla.jpg' - the event for the last segment
'/test' - the event for the 'test' segment
'' - the root event of each request
To actually handle any request you just have to register a callback for
the event name with the empty string. To handle all requests in the
'/test' directory you have to register a callback for the event with the
name '/test'. Here is an example how to register an event for the
example URL above:
$httpd->reg_cb (
'/test/bla.jpg' => sub {
my ($httpd, $req) = @_;
$req->respond ([200, 'ok', { 'Content-Type' => 'text/html' }, 'Test
' }]);
}
);
See also "stop_request" about stopping the walk of the path segments.
The first argument to such a callback is always the AnyEvent::HTTPD
object itself. The second argument ($req) is the
AnyEvent::HTTPD::Request object for this request. It can be used to get
the (possible) form parameters for this request or the transmitted
content and respond to the request.
Along with the above mentioned events these events are also provided:
request => $req
Every request also emits the "request" event, with the same
arguments and semantics as the above mentioned path request events.
You can use this to implement your own request multiplexing. You can
use "stop_request" to stop any further processing of the request as
the "request" event is the first thing that is executed for an
incoming request.
An example of one of many possible uses:
$httpd->reg_cb (
request => sub {
my ($httpd, $req) = @_;
my $url = $req->url;
if ($url->path =~ /\/images\/img_(\d+).jpg$/) {
handle_image_request ($req, $1); # your task :)
# stop the request from emitting further events
# so that the '/images/img_001.jpg' and the
# '/images' and '' events are NOT emitted:
$httpd->stop_request;
}
}
);
client_connected => $host, $port
client_disconnected => $host, $port
These events are emitted whenever a client coming from "$host:$port"
connects to your server or is disconnected from it.
CACHING
Any response from the HTTP server will have "Cache-Control" set to
"max-age=0" and also the "Expires" header set to the "Date" header.
Meaning: Caching is disabled.
You can of course set those headers yourself in the response, or remove
them by setting them to undef, but keep in mind that the default for
those headers are like mentioned above.
If you need more support here you can send me a mail or even better: a
patch :)
AUTHOR
Robin Redeker, ""
BUGS
Please report any bugs or feature requests to "bug-bs-httpd at
rt.cpan.org", or through the web interface at
. I will
be notified, and then you'll automatically be notified of progress on
your bug as I make changes.
SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AnyEvent::HTTPD
You can also look for information at:
* Git repository
* RT: CPAN's request tracker
* AnnoCPAN: Annotated CPAN documentation
* CPAN Ratings
* Search CPAN
ACKNOWLEDGEMENTS
Andrey Smirnov - for keep-alive patches.
Pedro Melo - for valuable input in general and patches.
Nicholas Harteau - patch for ';' pair separator support,
patch for allowed_methods support
Chris Kastorff - patch for making default headers removable
and more fault tolerant w.r.t. case.
Mons Anderson - Optimizing the regexes in L
and adding the C option to L.
COPYRIGHT & LICENSE
Copyright 2008-2011 Robin Redeker, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
libanyevent-httpd-perl-0.93/Makefile.PL 0000644 0001750 0001750 00000001631 11521521042 016746 0 ustar dimka dimka use strict;
use warnings;
use ExtUtils::MakeMaker;
WriteMakefile(
NAME => 'AnyEvent::HTTPD',
AUTHOR => 'Robin Redeker ',
VERSION_FROM => 'lib/AnyEvent/HTTPD.pm',
ABSTRACT_FROM => 'lib/AnyEvent/HTTPD.pm',
LICENSE => 'perl',
PL_FILES => {},
PREREQ_PM => {
'Test::More' => 0,
'AnyEvent' => 0,
'Object::Event' => 0,
'URI' => 0,
'Time::Local' => 0,
'common::sense' => 0,
'AnyEvent::HTTP' => 0,
'bytes' => 0,
'Compress::Zlib' => 0,
},
dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz',
PREOP => 'pod2text lib/AnyEvent/HTTPD.pm | tee README >$(DISTVNAME)/README; chmod -R u=rwX,go=rX . ;',
},
clean => { FILES => 'AnyEvent-HTTPD-*' },
);
libanyevent-httpd-perl-0.93/META.yml 0000644 0001750 0001750 00000001375 11616455751 016274 0 ustar dimka dimka --- #YAML:1.0
name: AnyEvent-HTTPD
version: 0.93
abstract: A simple lightweight event based web (application) server
author:
- Robin Redeker
license: perl
distribution_type: module
configure_requires:
ExtUtils::MakeMaker: 0
build_requires:
ExtUtils::MakeMaker: 0
requires:
AnyEvent: 0
AnyEvent::HTTP: 0
bytes: 0
common::sense: 0
Compress::Zlib: 0
Object::Event: 0
Test::More: 0
Time::Local: 0
URI: 0
no_index:
directory:
- t
- inc
generated_by: ExtUtils::MakeMaker version 6.57_05
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
version: 1.4
libanyevent-httpd-perl-0.93/t/ 0000755 0001750 0001750 00000000000 11616455751 015260 5 ustar dimka dimka libanyevent-httpd-perl-0.93/t/01_basic_request.t 0000644 0001750 0001750 00000002013 11537634345 020572 0 ustar dimka dimka #!perl
use common::sense;
use Test::More tests => 4;
use AnyEvent::Impl::Perl;
use AnyEvent;
use AnyEvent::Handle;
use AnyEvent::Socket;
use AnyEvent::HTTPD;
use AnyEvent::HTTPD::Util;
my $h = AnyEvent::HTTPD->new (port => 19090);
my $req_url;
my $req_url2;
my $req_method;
$h->reg_cb (
'' => sub {
my ($httpd, $req) = @_;
$req_url = $req->url->path;
},
'/test' => sub {
my ($httpd, $req) = @_;
$req_url2 = $req->url->path;
$req_method = $req->method;
$req->respond ({ content => ['text/plain', "Test response"] });
},
);
my $c = AnyEvent::HTTPD::Util::test_connect ('127.0.0.1', $h->port,
"GET\040http://localhost:19090/test\040HTTP/1.0\015\012\015\012");
my $buf = $c->recv;
my ($head, $body) = split /\015\012\015\012/, $buf, 2;
is ($req_url, "/test", "the path of the request URL was ok");
is ($req_url2, "/test", "the path of the second request URL was ok");
is ($req_method, 'GET', 'Correct method used');
is ($body, 'Test response', "the response text was ok");
libanyevent-httpd-perl-0.93/t/pod.t 0000644 0001750 0001750 00000000341 11444066620 016215 0 ustar dimka dimka #!perl -T
use common::sense;
use Test::More;
# Ensure a recent version of Test::Pod
my $min_tp = 1.22;
eval "use Test::Pod $min_tp";
plan skip_all => "Test::Pod $min_tp required for testing POD" if $@;
all_pod_files_ok();
libanyevent-httpd-perl-0.93/t/05_mp_param.t 0000644 0001750 0001750 00000004243 11444066620 017540 0 ustar dimka dimka #!perl
use common::sense;
use Test::More tests => 5;
use AnyEvent::Impl::Perl;
use AnyEvent;
use AnyEvent::HTTPD;
use AnyEvent::Socket;
my $c = AnyEvent->condvar;
my $h = AnyEvent::HTTPD->new;
my %params;
$h->reg_cb (
'/test' => sub {
my ($httpd, $req) = @_;
(%params) = $req->vars;
$req->respond ({
content => ['text/plain', "Test response"]
});
},
);
my $hdl;
my $buf;
tcp_connect '127.0.0.1', $h->port, sub {
my ($fh) = @_
or die "couldn't connect: $!";
$hdl =
AnyEvent::Handle->new (
fh => $fh,
on_read => sub { $hdl->rbuf = '' });
my $cont =
"--AaB03x\015\012Content-Disposition: form-data; name=\"submit-name\"\015\012"
. "\015\012Larry\015\012--AaB03x\015\012Content-Disposition: form-data; name=\"files\"; filename=\"file1.txt\"\015\012Content-Type: text/plain\015\012\015\012Test\015\012Test2\015\012"
. "--AaB03x\015\012Content-Disposition: form-data; name=\"files2\"; filename=\"file2.txt\"\015\012Content-Type: text/plain\015\012\015\012Test 2\015\012Test2\015\012"
. "--AaB03x\015\012Content-Disposition: form-data; name=\"files3\";\015\012Content-Type: multipart/mixed, boundary=BbC04y\015\012\015\012"
. "--BbC04y\015\012Content-disposition: attachment; filename=\"fileX1.txt\"\015\012Content-Type: text/plain\015\012\015\012"
. "BLABLABLA\015\012"
. "--BbC04y\015\012Content-disposition: attachment; filename=\"fileX2.xml\"\015\012Content-type: image/gif\015\012\015\012"
. "XXXXXXXXXXXXXXXXXXXX\015\012"
."--BbC04y--\015\012\015\012"
. "--AaB03x--\015\012";
$hdl->push_read (line => sub { $c->send });
$hdl->push_write (
"POST\040http://localhost:19090/test\040HTTP/1.0\015\012"
. "Content-Type: multipart/form-data; boundary=AaB03x\015\012"
. "Content-Length: " . length ($cont) . "\015\012\015\012$cont"
);
};
$c->recv;
is ($params{'submit-name'}, "Larry", "submit name");
is ($params{files}, "Test\015\012Test2", "files 1");
is ($params{files2}, "Test 2\015\012Test2", "files 2");
is ($params{files3}->[0], "BLABLABLA", "files 3.1");
is ($params{files3}->[1], "XXXXXXXXXXXXXXXXXXXX", "files 3.2");
libanyevent-httpd-perl-0.93/t/10_allowed_methods.t 0000644 0001750 0001750 00000003775 11537634345 021133 0 ustar dimka dimka #!perl
use common::sense;
use Test::More tests => 12;
use AnyEvent::Impl::Perl;
use AnyEvent;
use AnyEvent::HTTP;
use AnyEvent::HTTPD qw/http_request/;
my ($H, $P);
# make sure the default is GET HEAD POST
my $c = AnyEvent->condvar;
my $h = AnyEvent::HTTPD->new;
$h->reg_cb (
'' => sub {
my ($httpd, $req) = @_;
ok(scalar (grep { $req->method eq $_ } qw/GET HEAD POST/) == 1, "req " . $req->method );
if ($req->method eq 'POST')
{
ok($req->content eq 'hello world', "req POST body");
}
$req->respond({ content => ['text/plain', $req->method . " OK" ]});
},
client_connected => sub {
my ($httpd, $h, $p) = @_;
($H, $P) = ($h, $p);
},
);
is_deeply( $h->allowed_methods, [qw/GET HEAD POST/], 'allowed_methods()' );
http_request(
GET => sprintf("http://%s:%d/foo", '127.0.0.1', $h->port),
sub {
my ($body, $hdr) = @_;
ok($hdr->{'Status'} == 200, "resp GET 200 OK")
or diag explain $hdr;
ok($body eq 'GET OK', 'resp GET body OK')
or diag explain $body;
$c->send;
}
);
$c->recv;
$c = AnyEvent->condvar;
http_request(
POST => sprintf("http://%s:%d/foo", '127.0.0.1', $h->port),
body => 'hello world',
sub {
my ($body, $hdr) = @_;
ok($hdr->{'Status'} == 200, "resp POST 200 OK")
or diag explain $hdr;
ok($body eq 'POST OK', 'resp POST body OK')
or diag explain $body;
$c->send;
}
);
$c->recv;
$c = AnyEvent->condvar;
http_request(
HEAD => sprintf("http://%s:%d/foo", '127.0.0.1', $h->port),
sub {
my ($body, $hdr) = @_;
ok($hdr->{'Status'} == 200, "resp HEAD 200 OK")
or diag explain $hdr;
$c->send;
}
);
$c->recv;
$c = AnyEvent->condvar;
http_request(
OPTIONS => sprintf("http://%s:%d/foo", '127.0.0.1', $h->port),
sub {
my ($body, $hdr) = @_;
ok($hdr->{'Status'} == 501, "resp OPTIONS 501")
or diag explain $hdr;
ok($hdr->{'Reason'} == 'not implemented', 'resp OPTIONS reason')
or diag explain $hdr;
$c->send;
}
);
$c->recv;
done_testing();
libanyevent-httpd-perl-0.93/t/04_param.t 0000644 0001750 0001750 00000001221 11537634345 017044 0 ustar dimka dimka #!perl
use common::sense;
use Test::More tests => 2;
use AnyEvent::Impl::Perl;
use AnyEvent;
use AnyEvent::HTTPD;
my $h = AnyEvent::HTTPD->new (port => 19090);
my $req_q;
my $req_n;
$h->reg_cb (
'/test' => sub {
my ($httpd, $req) = @_;
$req_q = $req->parm ('q');
$req_n = $req->parm ('n');
$req->respond ({ content => ['text/plain', "Test response"] });
},
);
my $c = AnyEvent::HTTPD::Util::test_connect ('127.0.0.1', $h->port,
"GET\040http://localhost:19090/test?q=%3F%3F&n=%3F2%3F\040HTTP/1.0\015\012\015\012");
$c->recv;
is ($req_q, "??", "parameter q correct");
is ($req_n, "?2?", "parameter n correct");
libanyevent-httpd-perl-0.93/t/03_keep_alive.t 0000644 0001750 0001750 00000001753 11534654730 020056 0 ustar dimka dimka #!perl
use common::sense;
use Test::More tests => 1;
use AnyEvent::Impl::Perl;
use AnyEvent;
use AnyEvent::HTTPD;
use AnyEvent::Socket;
my $c = AnyEvent->condvar;
my $h = AnyEvent::HTTPD->new;
my $cnt = 0;
$h->reg_cb (
'/test' => sub {
my ($httpd, $req) = @_;
$cnt++;
$req->respond ({ content => ['text/plain', "Test response ($cnt)"] });
},
);
my $hdl;
my $buf;
tcp_connect '127.0.0.1', $h->port, sub {
my ($fh) = @_
or die "couldn't connect: $!";
$hdl =
AnyEvent::Handle->new (
fh => $fh, on_eof => sub { $c->send },
on_read => sub {
$buf .= $hdl->rbuf;
$hdl->rbuf = '';
if ($buf =~ /Test response \(2\)/) {
$c->send;
}
});
for (1..2) {
$hdl->push_write (
"GET\040http://localhost:19090/test\040HTTP/1.0\015\012"
. "Connection: Keep-Alive\015\012\015\012"
);
}
};
$c->recv;
is ($cnt, 2, 'two requests over one connection');
libanyevent-httpd-perl-0.93/t/07_param_semicolon.t 0000644 0001750 0001750 00000001252 11537634345 021123 0 ustar dimka dimka #!perl
use common::sense;
use Test::More tests => 2;
use AnyEvent::Impl::Perl;
use AnyEvent;
use AnyEvent::HTTPD;
use AnyEvent::HTTPD::Util;
my $h = AnyEvent::HTTPD->new (port => 19090);
my $req_q;
my $req_n;
$h->reg_cb (
'/test' => sub {
my ($httpd, $req) = @_;
$req_q = $req->parm ('q');
$req_n = $req->parm ('n');
$req->respond ({ content => ['text/plain', "Test response"] });
},
);
my $c = AnyEvent::HTTPD::Util::test_connect ('127.0.0.1', $h->port,
"GET\040http://localhost:19090/test?q=%3F%3F;n=%3F2%3F\040HTTP/1.0\015\012\015\012");
$c->recv;
is ($req_q, "??", "parameter q correct");
is ($req_n, "?2?", "parameter n correct");
libanyevent-httpd-perl-0.93/t/12_head_no_body.t 0000644 0001750 0001750 00000001002 11537634345 020352 0 ustar dimka dimka #!perl
use common::sense;
use Test::More tests => 1;
use AnyEvent::Impl::Perl;
use AnyEvent;
use AnyEvent::HTTPD;
use AnyEvent::Socket;
my $h = AnyEvent::HTTPD->new;
$h->reg_cb (
'/test' => sub {
my ($httpd, $req) = @_;
$req->respond ({ content => ['text/plain', "31337"] });
},
);
my $c = AnyEvent::HTTPD::Util::test_connect ('127.0.0.1', $h->port,
"HEAD\040http://localhost:19090/test\040HTTP/1.0\015\012\015\012");
my $buf = $c->recv;
ok ($buf !~ /31337/, "no body received");
libanyevent-httpd-perl-0.93/t/06_long_resp.t 0000644 0001750 0001750 00000001474 11537634345 017750 0 ustar dimka dimka #!perl
use common::sense;
use Test::More tests => 2;
use AnyEvent::Impl::Perl;
use AnyEvent;
use AnyEvent::HTTPD;
use AnyEvent::Socket;
my $h = AnyEvent::HTTPD->new;
my $SEND = "ELMEXBLABLA1235869302893095934";#"ABCDEF" x 1024;
my $SENT = $SEND;
$h->reg_cb (
'/test' => sub {
my ($httpd, $req) = @_;
$req->respond ({
content => ['text/plain', sub {
my ($data_cb) = @_;
return unless $data_cb;
$data_cb->(substr $SENT, 0, 10, '');
}]
});
},
);
my $c = AnyEvent::HTTPD::Util::test_connect ('127.0.0.1', $h->port,
"GET\040http://localhost:19090/test\040HTTP/1.0\015\012\015\012");
my $buf = $c->recv;
$buf =~ s/^.*?\015?\012\015?\012//s;
ok (length ($buf) == length ($SEND), 'sent all data');
ok (length ($SENT) == 0, 'send buf empty');
libanyevent-httpd-perl-0.93/t/14_header_unset.t 0000644 0001750 0001750 00000004061 11616454612 020413 0 ustar dimka dimka #!perl
use common::sense;
use Test::More tests => 8;
use AnyEvent::Impl::Perl;
use AnyEvent;
use AnyEvent::HTTPD;
my $h = AnyEvent::HTTPD->new (port => 19090);
$h->reg_cb (
'/header-unset' => sub {
my ($httpd, $req) = @_;
$req->respond (
[200, 'OK', {
'Cache-Control' => undef,
'Expires' => undef,
'Content-Length' => undef,
}, "Test response"]);
},
'/header-override-lowercase' => sub {
my ($httpd, $req) = @_;
$req->respond (
[200, 'OK', {
'cache-control' => "nonsensical",
}, "Test response"]);
},
'/header-override-uppercase' => sub {
my ($httpd, $req) = @_;
$req->respond (
[200, 'OK', {
'CACHE-CONTROL' => "nonsensical",
}, "Test response"]);
},
);
my $c1 = AnyEvent::HTTPD::Util::test_connect ('127.0.0.1', $h->port,
"GET\040/header-unset\040HTTP/1.0\015\012Connection: Keep-Alive\015\012\015\012");
my $c2 = AnyEvent::HTTPD::Util::test_connect ('127.0.0.1', $h->port,
"GET\040/header-override-lowercase\040HTTP/1.0\015\012\015\012");
my $c3 = AnyEvent::HTTPD::Util::test_connect ('127.0.0.1', $h->port,
"GET\040/header-override-uppercase\040HTTP/1.0\015\012\015\012");
my $r1 = $c1->recv;
my $r2 = $c2->recv;
my $r3 = $c3->recv;
unlike ($r1, qr/^expires:/im, "Can unset Expires header");
unlike ($r1, qr/^cache-control:/im, "Can unset Cache-Control header");
unlike ($r1, qr/^content-length:/im, "Can unset Content-Length header");
unlike ($r1, qr/^connection:\s*close$/im,
"Unsetting Content-Length implies no keep-alive");
like ($r2, qr/^cache-control:\s*nonsensical/im,
"Cache-Control set with lowercase gets through");
unlike ($r2, qr/^cache-control:\s*max-age/im,
"Cache-Control set with lowercase removes default header");
like ($r3, qr/^cache-control:\s*nonsensical/im,
"Cache-Control set with uppercase gets through");
unlike ($r3, qr/^cache-control:\s*max-age/im,
"Cache-Control set with uppercase removes default header");
libanyevent-httpd-perl-0.93/t/00-load.t 0000644 0001750 0001750 00000000233 11444066620 016567 0 ustar dimka dimka #!perl -T
use Test::More tests => 1;
BEGIN {
use_ok( 'AnyEvent::HTTPD' );
}
diag( "Testing AnyEvent::HTTPD $AnyEvent::HTTPD::VERSION, Perl $], $^X" );
libanyevent-httpd-perl-0.93/t/02_simple_requests.t 0000644 0001750 0001750 00000003211 11444066620 021157 0 ustar dimka dimka #!perl
use common::sense;
use Test::More tests => 8;
use AnyEvent::Impl::Perl;
use AnyEvent;
use AnyEvent::HTTPD;
use AnyEvent::Socket;
my $c = AnyEvent->condvar;
my $h = AnyEvent::HTTPD->new;
my $req_url;
my $req_hdr;
my ($H, $P);
$h->reg_cb (
'/test' => sub {
my ($httpd, $req) = @_;
$req_hdr = $req->headers->{'content-type'};
$req->respond ({
content => [
'text/plain',
"Test response\0"
. $req->client_host . "\0"
. $req->client_port
]
});
},
client_connected => sub {
my ($httpd, $h, $p) = @_;
ok ($h ne '', "got client host");
ok ($p ne '', "got client port");
($H, $P) = ($h, $p);
},
client_disconnected => sub {
my ($httpd, $h, $p) = @_;
is ($h, $H, "got client host disconnect");
is ($p, $P, "got client port disconnect");
}
);
my $hdl;
my $buf;
tcp_connect '127.0.0.1', $h->port, sub {
my ($fh) = @_
or die "couldn't connect: $!";
$hdl =
AnyEvent::Handle->new (
fh => $fh, on_eof => sub { $c->send ($buf) },
on_read => sub {
$buf .= $hdl->rbuf;
$hdl->rbuf = '';
});
$hdl->push_write (
"GET\040http://localhost:19090/test\040HTTP/1.0\015\012Content-Length:\015\012 10\015\012Content-Type: text/html;\015\012 charSet = \"ISO-8859-1\"; Foo=1\015\012\015\012ABC1234567"
);
};
my $r = $c->recv;
my ($tr, $host, $port) = split /\0/, $r;
ok ($tr =~ /Test response/m, 'test response ok');
ok ($req_hdr =~ /Foo/, 'test header ok');
ok ($host ne '', 'got a client host: ' . $host);
ok ($port ne '', 'got a client port: ' . $port);
libanyevent-httpd-perl-0.93/t/11_denied_methods.t 0000644 0001750 0001750 00000004120 11537634345 020716 0 ustar dimka dimka #!perl
use common::sense;
use Test::More tests => 13;
use AnyEvent::Impl::Perl;
use AnyEvent;
use AnyEvent::HTTP;
use AnyEvent::HTTPD qw/http_request/;
my ($H, $P);
# allow options, disallow POST
my $c = AnyEvent->condvar;
my $h = AnyEvent::HTTPD->new( allowed_methods => [qw/GET HEAD OPTIONS/] );
$h->reg_cb (
'' => sub {
my ($httpd, $req) = @_;
ok(scalar (grep { $req->method eq $_ } qw/GET HEAD OPTIONS/) == 1, "req " . $req->method );
if ($req->method eq 'POST')
{
ok(0, "got disallowed request");
$req->respond({ content => ['text/plain', $req->method . "NOT OK" ]});
}
else
{
ok(1, "got allowed request");
$req->respond({ content => ['text/plain', $req->method . " OK" ]});
}
},
client_connected => sub {
my ($httpd, $h, $p) = @_;
($H, $P) = ($h, $p);
},
);
is_deeply( $h->allowed_methods, [qw/GET HEAD OPTIONS/], 'allowed_methods()' );
http_request(
GET => sprintf("http://%s:%d/foo", '127.0.0.1', $h->port),
sub {
my ($body, $hdr) = @_;
ok($hdr->{'Status'} == 200, "resp GET 200 OK")
or diag explain $hdr;
ok($body eq 'GET OK', 'resp GET body OK')
or diag explain $body;
$c->send;
}
);
$c->recv;
$c = AnyEvent->condvar;
http_request(
POST => sprintf("http://%s:%d/foo", '127.0.0.1', $h->port),
body => 'hello world',
sub {
my ($body, $hdr) = @_;
ok($hdr->{'Status'} == 501, "resp POST 501")
or diag explain $hdr;
ok($hdr->{'Reason'} == 'not implemented', 'resp POST reason')
or diag explain $hdr;
$c->send;
}
);
$c->recv;
$c = AnyEvent->condvar;
http_request(
HEAD => sprintf("http://%s:%d/foo", '127.0.0.1', $h->port),
sub {
my ($body, $hdr) = @_;
ok($hdr->{'Status'} == 200, "resp HEAD 200 OK")
or diag explain $hdr;
$c->send;
}
);
$c->recv;
$c = AnyEvent->condvar;
http_request(
OPTIONS => sprintf("http://%s:%d/foo", '127.0.0.1', $h->port),
sub {
my ($body, $hdr) = @_;
ok($hdr->{'Status'} == 200, "resp OPTIONS OK")
or diag explain $hdr;
$c->send;
}
);
$c->recv;
done_testing();
libanyevent-httpd-perl-0.93/MANIFEST 0000644 0001750 0001750 00000001222 11616455751 016143 0 ustar dimka dimka Changes
MANIFEST
Makefile.PL
README
t/00-load.t
t/pod.t
lib/AnyEvent/HTTPD/HTTPServer.pm
lib/AnyEvent/HTTPD/HTTPConnection.pm
lib/AnyEvent/HTTPD/Request.pm
lib/AnyEvent/HTTPD/Util.pm
lib/AnyEvent/HTTPD.pm
samples/simple_example
samples/bshttp.png
samples/second_example
samples/delayed_example
samples/delayed_2_example
samples/large_response_example
t/00-load.t
t/01_basic_request.t
t/02_simple_requests.t
t/03_keep_alive.t
t/04_param.t
t/05_mp_param.t
t/06_long_resp.t
t/07_param_semicolon.t
t/10_allowed_methods.t
t/11_denied_methods.t
t/12_head_no_body.t
t/14_header_unset.t
META.yml Module meta-data (added by MakeMaker)
libanyevent-httpd-perl-0.93/samples/ 0000755 0001750 0001750 00000000000 11616455751 016461 5 ustar dimka dimka libanyevent-httpd-perl-0.93/samples/second_example 0000755 0001750 0001750 00000001367 11444066620 021374 0 ustar dimka dimka #!/opt/perl/bin/perl
use common::sense;
use AnyEvent;
use AnyEvent::HTTPD;
my $cvar = AnyEvent->condvar;
my $httpd = AnyEvent::HTTPD->new (port => 19090);
$httpd->reg_cb (
'' => sub {
my ($httpd, $req) = @_;
$req->respond ({ content => [ 'text/html',
"Testing return types...
"
. "![](\"/image/bshttp.png\")
"
. ""
]});
},
'/image/bshttp.png' => sub {
$_[0]->stop_request;
open IMG, 'bshttp.png'
or do { $_[1]->respond (
[404, 'not found', { 'Content-Type' => 'text/plain' }, 'Fail!']);
return };
$_[1]->respond ({ content => [ 'image/png', do { local $/; ![]()
} ] });
},
);
$cvar->wait;
libanyevent-httpd-perl-0.93/samples/large_response_example 0000755 0001750 0001750 00000005172 11444066620 023127 0 ustar dimka dimka #!/opt/perl/bin/perl
use common::sense;
use AnyEvent;
use AnyEvent::HTTPD;
use AnyEvent::AIO;
use IO::AIO;
my $cvar = AnyEvent->condvar;
my $httpd = AnyEvent::HTTPD->new (port => 19090);
my $SEND_FILE = defined $ARGV[0] ? $ARGV[0] : 'bshttp.png';
my $mime = `file -i $SEND_FILE`;
$mime =~ s/^(.*?): //;
$mime =~ s/\r?\n$//;
print "going to send $SEND_FILE: $mime\n";
sub send_file {
my ($req) = @_;
my $fh;
my $last_pos = 0;
print "going to open $SEND_FILE...\n";
# use IO::AIO to async open the file
aio_open $SEND_FILE, O_RDONLY, 0, sub {
$fh = shift;
unless ($fh) {
warn "couldn't open $SEND_FILE: $!\n";
$data_cb->(); # stop sending data...
return;
}
my $size = -s $fh;
print "opened $SEND_FILE, $size bytes big!\n";
# make a reader callback, that will be called
# whenever a chunk of data was written out to the kernel
my $get_chunk_cb = sub {
my ($data_cb) = @_;
if ($data_cb) {
print "get next chunk, $last_pos of $size!\n";
} else {
print "sent last chunk, no more required!\n";
}
return unless $data_cb; # in case the connection went away...
my $chunk = '';
# use IO::AIO again, to async read from disk
# you decide what chunks you want to send btw.
# here we send 4096 bytes on each chunk read.
aio_read $fh, $last_pos, 4096, $chunk, 0, sub {
if ($_[0] > 0) {
$last_pos += $_[0];
print "read $_[0] bytes, sending them...\n";
$data_cb->($chunk); # when we got another chunk, push it
# over the http connection;
$chunk = '';
# and here we just return, and wait for the next call to
# $get_chunk_cb when the data is in the kernel.
} else {
$data_cb->(); # stop sending data (in case of error or EOF)
return;
}
};
};
$req->respond (
[
200, 'ok', {
'Content-Type' => $mime,
# 'Content-Length' => $size
},
$get_chunk_cb
]
);
};
}
$httpd->reg_cb (
'' => sub {
my ($httpd, $req) = @_;
$req->respond ({ content => ['text/html', <<'CONT']});
Large Download Example!
download file
CONT
},
'/test' => sub {
my ($httpd, $req) = @_;
$httpd->stop_request;
print "sending file ...\n";
send_file ($req);
},
);
$cvar->wait;
libanyevent-httpd-perl-0.93/samples/delayed_example 0000755 0001750 0001750 00000001543 11444066620 021524 0 ustar dimka dimka #!/opt/perl/bin/perl
use common::sense;
use AnyEvent;
use AnyEvent::HTTPD;
my $cvar = AnyEvent->condvar;
my $httpd = AnyEvent::HTTPD->new (port => 19090);
my $timer;
$httpd->reg_cb (
'' => sub {
my ($httpd, $req) = @_;
$req->respond ({ content => [ 'text/html',
"Testing return types...
"
. ""
. ""
]});
},
'/image/bshttp.png' => sub {
my ($httpd, $req) = @_;
$httpd->stop_request;
$timer = AnyEvent->timer (after => 3, cb => sub {
open IMG, 'bshttp.png' or do { $req->respond; return }; # respond without output will
# generate a 404
$req->respond ({ content => [ 'image/png', do { local $/; ![]()
} ] });
});
},
);
$cvar->wait;
libanyevent-httpd-perl-0.93/samples/bshttp.png 0000644 0001750 0001750 00000041617 11444066620 020474 0 ustar dimka dimka PNG
IHDR , P pHYs tIME52`ԋ tEXtComment Created with The GIMPd%n IDATxy@g &@آAYD(*V-BEEZTZ[Պ*}+u)*EEAGJ{q2sf;yγ b b b b b b b b v v v v v v v v v b b b b b b b @ @ ,++#Ғq\& 7 n"vqqq.]z7o:th@@93 ^A\\ܮ]rrrZ/^xOD`` w )H4lӷlrڵjff`jj+Ilnn322p84
+ meddt$I4556mZhhZ 4Wrss;34D"|>qF w V4+T,+r_xqٲepw PW1))믿 &]SS{MP B|v"HGFacc#333wh4H; b'3_V߿_RR" 7o ;v,== $I]]][[ۏ>? 5j <^ bױHÔE}}}VV|j>DD"
SRR7vX @s ]^^x@$d'NZvs||%O>ꫯ >| u@fffKK(Hd2K~G )=_߾} O 2=eeeXKS.FDrrrMM
²~ɇ ~R.Ç ̸_~N<ƍˎz@ 8sLVVN˗YYY v XZZ2 6埕u-%ƾ477?{ 0 k366F!IR?-┛aFdmm-^E!XڠA:
vqqaX+O u 6L2$IYPPו+Wv(j Cwwwx NQ[Έ
X={vrAAA 1(( p@ݻ7" k}WUL/A.]z7o:th@@/ ;EIOON[[[#`XZZvfI177 xrR< ]PψV433Sp[> ;-K:>h OB-D 6
O>[6=zs̴b߿x]]]WW-[ ?ʮ]UYM]ys1OOϮq&J4 ???^˗~>ɓ%@_999GիW>}/INNzrH۷oXXÇB|?wa3>Lǻd*,]LVƌI}}˗/e=l<]]]LLLyNNN111?Hvv6z!qqq}E?fffyyyV|||~'.--U|xy Cb2{!:"U,>}zʕ,hݡ':::FFFVVVcƌ6m577O((} E>rss%+++S3߳gϑ#G#ǎ /RYY)? F !C,ZhرVVV߿qq1bLzzK^Q]HHHdd$mqqkBBBzaom~ Lii) MsEEŶm~&e˖iMk.t=D566{ԨQǏ㏝^gX&MFiiio===mmm4 :(E%IH'z*ZkT ӻwΜ9ԩS_O?t Zxرѣ_&G uqq9GC8_tҋ/w 6 }ݫxaaCCC}}}EEE=Q8 fr8 #!'Իk 555'O\dIRRfXwVܬ ׯp@PP|R̻w.ZhܹG }V PTTT/(XX$Ii\zXiiݻwci9;;#ΪuPX[[T
Fĵoo W*D__˖-TTT:ujڵb{e:槾>..nժU3gΌua;p3,Hn߾}Y)~*bɓ'߾}KEEETϟ_TT_E>}&"kLOΝ;Oڴij`SnjsٚSSSxbllҢ䘙a]Cׯ_qbͷoo߾K.a` (M(ly???-l``i&ŷ_~h"JS
omnMR윗'
5kփ N"444nڴmӦM,=z4sXv;wu`ZJ_/)) ղ
~~~}Uޑիe .Pn
}"3|=;f!R^WYYRN"`5TTThakj2`0"##骪VZ%S
̴GFDD̙3gԩ'O>^y&HS9---Ttuu
4D;Ӑ%jgEd} :G܌Vo߮˗}}}3V\Iqr ?Ne1qfbb
; G^^ =Zsl%죳qFM8Ϙx}0aLZ3r[n]CPd8qbر{GEEQ4{wIlh[f
ŋrwE0.?ϘwMMM|܆7nL0A&' FWMG~AAUdp@[yǎ ZӧO.Ǐ 744r;wVWWq}ȟ} ԽXB|vppPuĮW^k2$[ׯ_wÈb* SN3g"&&&G .a4Htt+f̘1ydoooGGGK$؈
[n;ڕhHFZDBXiZu ( O1erՄVV\n'GGGG hv
Hܼy&jZZuҩP;TVVnlO8dܸqԟh%]\\d
b[QᨿVAVWW'G%YcJ7QVnܙq'qW^^vZ?LL5UԝNǏ ״F Nא6D-dž`ȝ۟`r3%VVV }HONeB&Feeȑ#)S={V(R|899vxI||f; ]n݇AA$IO^zu51!biui|+Hnݺ%뿒ܷo_]]vҝʮÆ
C/X,@HaWr4 u)tkmwwwquP٦ss@ ɓzDBӍ---y<5͖{VctT__֦tҏ?+ůӧ@ բݻw{N>Yߺu?0`Z|aGqŋ#DOOo .\hhh@f~~ ח_v
=R$'''#dzڴih 2d[hj1)gzN%EULdPx!i xU;a-o***{qrWOOOxT6|͛ɒCbsNUuelD
>;+e@pܹ'O(SRR~ɓ'[ZZ'ObMcĉh~uAA l6Cۏ\]]ϝ;5~bq\\ ÁՂ Çah]@Q<J9//OA|ɓ'i%?? oR ^^^hIKK !w/++{|'k.lÊÇWWW#̙3PN>X8,++~+W:;;SЬkUvX{nII z$\ɓѱ#$11cӦMî Ta܁(Jl߾ #
ߧx K7o ;% r1Vi"5Iq h)**Wqb(RFsuuݽ{_|d2~'?NHuuƝ/Sq{nBO#M{CCCEr\t By 0h F'\`DıcǔkO IDATMPfc[}hӦMCːH$믿dJи[x1{Fqw ō PO*Ij:CݦM>g2ʑ4T .;DCnP(@qpp@1%ɝ;waÆ%/\q'.]#ȇvI$lrWʭ ya(< v4|G lب. $;[ɒ$6VozU ڑxb;Z@H$
Y6=bĈv((((..z&dHHȥK
80~xķmͧOF%$$_|:&qm$I4H+e&矯_~_tqqA"rqqio
Rcǎ W^U>>=
F stɯ555mܸq
6_tOOOHՅU ..lrܠ:::}kkka;;;~WxNIII^^z
6 #nnnI/
EA mk5x`/0uTO 8J%9./\[WWݷ!իWCݻw~ 9`=[gUL.^HQDeٻIII؏իEdd$400XIb8 䤶.!!!?s P(Do$b
ЈĆall|N#puu5R,DVB?]D 8,((v25ߓ'Ob?fA ;:[3nƌZmL84#Nzn^.\(q>;@ \r=Ą
١n>YC ٳg ĥۗt%3mkM+իA\~㝝):ݻ'N;Vp >|86])b8ؽG L/^}:̔H$\=%MqEtUCooﰰ0l`KK{݄ DD4;mEmӧObקO prrB/^RO C2QF?Mmvvڡfz*:'$$/**ڻw/< vځ\
Pe*-555>=UUUjĉSQQYh%Ov ]ŅJC%''S ;@=.g@]&IrĈʺ(OOOכ$It)J%2|pS|۶mZ $ͮWϧ#;88hjjBgTc[iq9a >\Yfia.u16aJH$JLLDOITFGGg̘1mDwx c̘1T?5
N;P[EW^k )Aj;&]7G^~]
L&]sN+
lXRB2=ӧh #""{ܹs+]7A=.;ww'l }4DPV&NIllloo5Me%D}jj*&h4*ބ +geea9sPqٳ[N;PC%@ͯVV
6,ٳgJZGE/٣g⇕ݻKwmm˗t400X X0C?jjj+_3 1$Iee#".ӧOǦj >|Xa1C A/bɓ']UU՟=&I +J{ڵk2߿D$
|T!v...híVm]\Lf@@ jBرcὩw
.A3gb I)1cƠdgg?| 3f A۶m v֏322Rq8 >rcc˗/6 Teee[n (7 }Vvϝ;G{`oo?o}>og̘r
RM>}ؑ[@UUTT|QF)=``'.!L&sTȔ) 88mfJtMLLN:~^r {{ qֵܹN N%4,, ;211̙3 vi4u }N6oތi###[*Btt4K֭[PQQM366khh} tttLNz.C>fPl)H- l6XFFɓ[wb$^zb&H&&&NNN f3ӧOc+; )AP:fJIIA Tzbq?)裏lmmSSSBa X,V<,kʕ_~%x ~\ˣ?s`4iԗít###ѣGc Ƀ
*\QT$I߿K=55J
e˖|w]N8qD8h *ބ}(Y755˗III߿GÑ#GRrAQpf[ }vCCCПy=y]5ET;l>urr2 iIdvymmm;o/ve̙;>6_FOOe˖aGũ@ vY[TVe8|[ v g#F` gM;
/_^TTԅS-ZUxyy@%oF]m:ں@ zH{rA ;677W ܱcb%b'`MXX,cWZ\.===*> ujjjV 1?vX^^މ'jjjL&sѢE؇sgooxblc
*4rrr:,Zיqw-;@Eo!-s͛.ǏҊ0&&J+Ǧ777 ;vL]}nj]O`SekkkwڅؖW^h C֍>LV]*l#n݊ VSS ]PP_Mw^:|J[dȇ z :UV(^p?:H$B)IϟͩN*_vsss?|&L݄ >S찔s)ݸ={6f%&&^vM;___llg{"(11ￗE A1i$Y lPi{ .ܹs;pƍ5*(d=pYiii}}}SSIUUU999h b'O#}L:a!Gaee97 OULx [ZZ4-U?d2uuu(]L$edd`6lDMVTV'k֬ZɪZ[dt)9SpQ@ h6]L|Ǐ 4\Co ,^Ud2̥KRu/4gLLLn;b `ŰQZZ+ +++to#vÒ%K<{zA5$Pٙi=JOVG 033YSSS:EuMmf̙؍؍7*}
N&OLX,rJllLĉ?]vSw@z( tKK.6R$IYYM&á~,::J;SSӰ0*m^z!qHHȂ lll
uuuuuu
H 4hпǣ? v=-ݻ7ڲCWsͱ}]scǎw c Î,((طơM9k֬Ea+ d2~?F7( N|jT== &aE,L 8_|9c{ժUMwӦM6mZpssMIIk$ijjjgg ]$ٙN;PzZ07n܅ #+** <8j(3nܸqy|ee}vڥ3inn 222rss[D ظDKKK;G'ZIh\dIJJ#E"۷KJJ:ed.XѣG蛫Q]F"t;\\\X,VUUUvtdl<}~`ek֭T|yzz`c] x);@bBpʕaJ;j6 7|finnUdO0=LjiȶrAAA 0stt.v]lOB}}}OhNLLL֭[tR"߸qCE`kk ]n-`0֭v, D;v=zU`W?7n,**Bw)))),,Wϛ7]Kɞ;h̔dZZZx<. l~???*)**Tx"}n25*~w(/_\E.ͱbŊ2V;PVXjj*6[
dޅ|D˗/3$I...AAAX]LL**h& v=lÇG ?~22oR"JU ;wˍ/Įg-kN=-Q] s;PC;; $i``@8Rb:ͱeTW;;ٳgo߾T=Z: #?
̙M! PXXXZZs8 * mz䉊v-\;;`h
H$< ʡYT:ZÃf SSS3gĆ -[]۷o^ #AGuߟ|>_[(pwwG
l2qm% b*-===)FYYY!= ++^:^~i
8;;j455ɓ 56mڤ* v U) ̬Ê ݻT- L&Hէp,Y bt
Ϟ=C̨6ãzxx 6kwРAh]}}}qq>kkiӦ!lРA>
]ccM4=]rg̘ៜf̘ nҢEo#F
E46QÙP4Ϟ= btMMMe }ikJ ~t:.-vZ___6iOOOR[Mڸq9s_~fp; ;
WU\`١O>ps;e 9rdʔ)'O|A!!!ԭrwK.]v-z؛7oUoTp̙3gN7d>f͚`LMMl'O 4bll|fgu"Jb-]tɒ%m{ta*maƍwT~h2%%%5ٳ]]]U{ĈNNN C__zر_}Uhh(=SoEYZZ>~K b WWT {
'--
Q/--
f OR0t2V`@prru}XjN\"]]]++1c,Z X ={ݻw1"HGG'88{\24@"&6P IDAT@zwA I&%%5\/ bɈƍZTS ݾ} -db_ @8q"w~=; ///lCu
v УrCEKII @a2 ,@ =YNuuIIIvvv` X &TVV,c n.\ޓD'NТ& v t #Aiii.\謴" Z A566^v-// m`L8[SZz -?3. v AX,???۶W ?\ 1 ~ӦM v2l0 b 3-[th
<8 @{condvar;
my $httpd = AnyEvent::HTTPD->new (port => 19090);
$httpd->reg_cb (
'' => sub {
my ($httpd, $req) = @_;
$req->respond ({ content => ['text/html', <<'CONT']});
Hello World!
another test page
CONT
},
'/test' => sub {
my ($httpd, $req) = @_;
$httpd->stop_request;
$req->respond ({ content => ['text/html', <<'CONT']});
Test page
Back to the main page
CONT
},
);
$cvar->wait;
libanyevent-httpd-perl-0.93/samples/delayed_2_example 0000755 0001750 0001750 00000001270 11444066620 021742 0 ustar dimka dimka #!/opt/perl/bin/perl
use common::sense;
use AnyEvent::HTTPD;
my $httpd = AnyEvent::HTTPD->new (port => 19090);
my $t;
$httpd->reg_cb (
'' => sub {
my ($httpd, $req) = @_;
my $html =
"Hello World!
"
. "another test page"
. "";
$req->respond ({ content => ['text/html', $html] });
},
'/test' => sub {
my ($httpd, $req) = @_;
$httpd->stop_request;
$t = AnyEvent->timer (after => 2, cb => sub {
my $txt = "CPU info:\n\n" . `cat /proc/cpuinfo`;
$req->respond ([200, "ok", { 'Content-Type' => 'text/plain' }, $txt]);
});
},
);
$httpd->run;
libanyevent-httpd-perl-0.93/Changes 0000644 0001750 0001750 00000010600 11616455164 016303 0 ustar dimka dimka Revision history for AnyEvent-HTTPD
0.93 Thu Aug 4 10:38:09 CEST 2011
- made it possible to remove default headers
completely, thanks go to Chris Kastorff for providing a patch.
- applied also a fix for case handling of the headers,
thanks go to the patch from Chris Kastorff.
- fixed some tests. I hate it when all bugs that
are found via CPAN Testers are bugs in the tests.
- fixed that the URL returned by Request::url method will
now also contain the query string (thanks to art sackett for
spotting this).
0.92 Tue Mar 1 11:46:14 CET 2011
- added simple SSL/TLS support.
- removed from tests from the distribution.
- replaced 01_basic_request.t with a non-wget variant for CPAN.
0.91 Wed Feb 2 15:21:02 CET 2011
- set the Date header correctly.
- append a newline to error messages.
- hopefully improved connection closing mechanism.
- don't send body when responding to a HEAD request.
0.90 Mon Jan 31 13:04:45 CET 2011
- fixed a small thing with response on dead connections.
- added small example of 'request' event usage.
- make Content-Length: not be empty.
- hand HEAD requests down to the event handlers.
- added allowed_methods support from nrh.
- don't force cache policy anymore.
0.84 Mon Nov 9 17:18:07 CET 2009
- added client_connected and client_disconnected events.
- returning 501 instead of 405 on unimplemented method.
- optimized regexes (contributed by Mons Anderson).
- added backlog option to AE::HTTPD (contributed by Mons Anderson).
0.83 Tue Sep 29 16:29:57 CEST 2009
- added client host and port to the request.
0.82 Tue Aug 11 08:33:05 CEST 2009
- added common::sense to prereq.
- made tests using 127.0.0.1.
0.81 Mon Aug 10 09:59:16 CEST 2009
- cleaned up dependencies in Makefile.PL.
- using common::sense in all modules & scripts.
0.8 Sun Aug 9 18:10:23 CEST 2009
- made tests run with AnyEvent::Impl::Perl.
- removed HTTP::Date (LWP) dependency.
0.71 Sat Aug 8 00:43:58 CEST 2009
- fixed the published tests. they used Coro.
0.7 Fri Aug 7 15:37:27 CEST 2009
- fixed documentation in AE::HTTP::Request.
- added asynchronous response functionality,
for sending large files via AnyEvent::AIO for instance.
- added tests to distribution (instead of maintainer only tests).
- fixed a bug with reception of requests without headers.
0.6 Tue Jul 14 11:16:44 CEST 2009
- fixed leaking AE::HTTPD::HTTPConnection.
0.5 Thu Jul 2 04:30:14 CEST 2009
- applied patch from mathieu at closetwork.org to add a
host parameter for binding.
- removed bogus API stuff like ::Appgets or the weird
form and response handling. AnyEvent::HTTPD should be and
stay a simple HTTP server for simple purposes.
If you need further sugar, please write your own modules for
it. If you need anything ask me or look in the git repository
at http://git.ta-sa.org/AnyEvent-HTTPD.git
- added responded method to ::Request.
- stop_request now also stops further handling of the request
after the 'request' event.
- added 'request_timeout's
- added keep-alive support (for HTTP 1.0) (thanks to Andrey Smirnov).
0.04 Sun Dec 28 15:48:28 CET 2008
- removed TCP* classes and using AnyEvent::Handle instead.
- added size and maxlength args to the C function in Appgets
- changed the API to actually call the events for all path segments
of an URL. also removed the ugly '/' => '_' mapping for the path
seperators. Sorry for any breakage in your code ;-/
- removed Perl 5.10 dependency.
0.03 Tue Apr 15 12:57:10 CEST 2008
- added submit() function to Appgets.
- fixed a bug in the url() method of AnyEvent::HTTPD::Request where
the url wasn't get correctly. resulting in bad form behaviour.
0.02 Sat Mar 22 16:09:55 CET 2008
- rewrote the module API to be more "async".
- made it possible to respond to requests asynchronously
in C.
- added lots of example scripts.
0.01 Thu Mar 20 19:53:31 CET 2008
- first release.
libanyevent-httpd-perl-0.93/lib/ 0000755 0001750 0001750 00000000000 11616455751 015563 5 ustar dimka dimka libanyevent-httpd-perl-0.93/lib/AnyEvent/ 0000755 0001750 0001750 00000000000 11616455751 017314 5 ustar dimka dimka libanyevent-httpd-perl-0.93/lib/AnyEvent/HTTPD/ 0000755 0001750 0001750 00000000000 11616455751 020177 5 ustar dimka dimka libanyevent-httpd-perl-0.93/lib/AnyEvent/HTTPD/Util.pm 0000644 0001750 0001750 00000006103 11616455621 021446 0 ustar dimka dimka package AnyEvent::HTTPD::Util;
use AnyEvent;
use AnyEvent::Socket;
use common::sense;
require Exporter;
our @ISA = qw/Exporter/;
our @EXPORT = qw/parse_urlencoded url_unescape header_set
header_get header_exists/;
=head1 NAME
AnyEvent::HTTPD::Util - Utility functions for AnyEvent::HTTPD
=head1 SYNOPSIS
=head1 DESCRIPTION
The functions in this package are not public.
=over 4
=cut
sub url_unescape {
my ($val) = @_;
$val =~ s/\+/\040/g;
$val =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr (hex ($1))/eg;
$val
}
sub parse_urlencoded {
my ($cont) = @_;
my (@pars) = split /[\&\;]/, $cont;
$cont = {};
for (@pars) {
my ($name, $val) = split /=/, $_;
$name = url_unescape ($name);
$val = url_unescape ($val);
push @{$cont->{$name}}, [$val, ''];
}
$cont
}
sub test_connect {
my ($host, $port, $data) = @_;
my $c = AE::cv;
my $t; $t = AnyEvent->timer (after => 0.1, cb => sub {
my $hdl;
my $buf;
undef $t;
tcp_connect $host, $port, sub {
my ($fh) = @_
or die "couldn't connect: $!";
$hdl =
AnyEvent::Handle->new (
fh => $fh,
timeout => 15,
on_eof => sub {
$c->send ($buf);
undef $hdl;
},
on_timeout => sub {
warn "test_connect timed out";
$c->send ($buf);
undef $hdl;
},
on_read => sub {
$buf .= $hdl->rbuf;
$hdl->rbuf = '';
});
$hdl->push_write ($data);
};
});
$c
}
###
# these functions set/get/check existence of a header name:value pair while
# ignoring the case of the name
#
# quick hack, does not scale to large hashes. however, it's not expected to be
# run on large hashes.
#
# a more performant alternative would be to keep two hashes for each set of
# headers, one for the headers in the case they like, and one a mapping of
# names from some consistent form (say, all lowercase) to the name in the other
# hash, including capitalization. (this style is used in HTTP::Headers)
sub _header_transform_case_insens {
my $lname = lc $_[1];
my (@names) = grep { $lname eq lc ($_) } keys %{$_[0]};
@names ? $names[0] : $_[1]
}
sub header_set {
my ($hdrs, $name, $value) = @_;
$name = _header_transform_case_insens ($hdrs, $name);
$hdrs->{$name} = $value;
}
sub header_get {
my ($hdrs, $name) = @_;
$name = _header_transform_case_insens ($hdrs, $name);
exists $hdrs->{$name} ? $hdrs->{$name} : undef
}
sub header_exists {
my ($hdrs, $name) = @_;
$name = _header_transform_case_insens ($hdrs, $name);
# NB: even if the value is undefined, return true
return exists $hdrs->{$name}
}
=back
=head1 AUTHOR
Robin Redeker, C<< >>
=head1 SEE ALSO
=head1 COPYRIGHT & LICENSE
Copyright 2009-2011 Robin Redeker, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1;
libanyevent-httpd-perl-0.93/lib/AnyEvent/HTTPD/HTTPServer.pm 0000644 0001750 0001750 00000004077 11616455572 022514 0 ustar dimka dimka package AnyEvent::HTTPD::HTTPServer;
use common::sense;
use Scalar::Util qw/weaken/;
use Object::Event;
use AnyEvent::Handle;
use AnyEvent::Socket;
use AnyEvent::HTTPD::HTTPConnection;
our @ISA = qw/Object::Event/;
=head1 NAME
AnyEvent::HTTPD::HTTPServer - A simple and plain http server
=head1 DESCRIPTION
This class handles incoming TCP connections for HTTP clients.
It's used by L to do it's job.
It has no public interface yet.
=head1 COPYRIGHT & LICENSE
Copyright 2008-2011 Robin Redeker, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = {
connection_class => "AnyEvent::HTTPD::HTTPConnection",
allowed_methods => [ qw/GET HEAD POST/ ],
@_,
};
bless $self, $class;
my $rself = $self;
weaken $self;
$self->{srv} =
tcp_server $self->{host}, $self->{port}, sub {
my ($fh, $host, $port) = @_;
unless ($fh) {
$self->event (error => "couldn't accept client: $!");
return;
}
$self->accept_connection ($fh, $host, $port);
}, sub {
my ($fh, $host, $port) = @_;
$self->{real_port} = $port;
$self->{real_host} = $host;
return $self->{backlog};
};
return $self
}
sub port { $_[0]->{real_port} }
sub host { $_[0]->{real_host} }
sub allowed_methods { $_[0]->{allowed_methods} }
sub accept_connection {
my ($self, $fh, $h, $p) = @_;
my $htc =
$self->{connection_class}->new (
fh => $fh,
request_timeout => $self->{request_timeout},
allowed_methods => $self->{allowed_methods},
ssl => $self->{ssl},
host => $h,
port => $p);
$self->{handles}->{$htc} = $htc;
weaken $self;
$htc->reg_cb (disconnect => sub {
if (defined $self) {
delete $self->{handles}->{$_[0]};
$self->event (disconnect => $_[0], $_[1]);
}
});
$self->event (connect => $htc);
}
1;
libanyevent-httpd-perl-0.93/lib/AnyEvent/HTTPD/Request.pm 0000644 0001750 0001750 00000014617 11616455601 022170 0 ustar dimka dimka package AnyEvent::HTTPD::Request;
use common::sense;
=head1 NAME
AnyEvent::HTTPD::Request - A web application request handle for L
=head1 DESCRIPTION
This is the request object as generated by L and given
in the request callbacks.
=head1 METHODS
=over 4
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = { @_ };
bless $self, $class
}
=item B
This method returns the URL of the current request as L object.
=cut
sub url {
my ($self) = @_;
my $url = $self->{url};
my $u = URI->new ($url);
$u
}
=item B
C<$res> can be:
=over 4
=item * an array reference
Then the array reference has these elements:
my ($code, $message, $header_hash, $content) =
[200, 'ok', { 'Content-Type' => 'text/html' }, 'Test
' }]
You can remove most headers added by default (like C,
C, and C) by setting them to undef, like so:
$req->respond([
200, 'OK', {
'Content-Type' => 'text/html',
'Cache-Control' => 'max-age=3600',
'Expires' => undef,
},
'This data will be cached for one hour.'
]);
=item * a hash reference
If it was a hash reference the hash is first searched for the C
key and if that key does not exist for the C key.
The value for the C key should contain the URL that you want to redirect
the request to.
The value for the C key should contain an array reference with the first
value being the content type and the second the content.
=back
Here is an example:
$httpd->reg_cb (
'/image/elmex' => sub {
my ($httpd, $req) = @_;
open IMG, "$ENV{HOME}/media/images/elmex.png"
or $req->respond (
[404, 'not found', { 'Content-Type' => 'text/plain' }, 'not found']
);
$req->respond ({ content => ['image/png', do { local $/; ![]()
}] });
}
);
B
For longer responses you can give a callback instead of a string to
the response function for the value of the C<$content>.
$req->respond ({ content => ['video/x-ms-asf', sub {
my ($data_cb) = @_;
# start some async retrieve operation, for example use
# IO::AIO (with AnyEvent::AIO). Or retrieve chunks of data
# to send somehow else.
} });
The given callback will receive as first argument either another callback
(C<$data_cb> in the above example) or an undefined value, which means that
there is no more data required and the transfer has been completed (either by
you sending no more data, or by a disconnect of the client).
The callback given to C will be called whenever the send queue of the
HTTP connection becomes empty (meaning that the data is written out to the
kernel). If it is called you have to start delivering the next chunk of data.
That doesn't have to be immediately, before the callback returns. This means
that you can initiate for instance an L request (see also
L) and send the data later. That is what the C<$data_cb>
callback is for. You have to call it once you got the next chunk of data. Once
you sent a chunk of data via C<$data_cb> you can just wait until your callback
is called again to deliver the next chunk.
If you are done transferring all data call the C<$data_cb> with an empty string
or with no argument at all.
Please consult the example script C from the
C directory of the L distribution for an example of
how to use this mechanism.
B You should supply a 'Content-Length' header if you are going to send a
larger file. If you don't do that the client will have no chance to know if the
transfer was complete. To supply additional header fields the hash argument
format will not work. You should use the array argument format for this case.
=cut
sub respond {
my ($self, $res) = @_;
return unless $self->{resp};
my $rescb = delete $self->{resp};
if (ref $res eq 'HASH') {
my $h = $res;
if ($h->{redirect}) {
$res = [
301, 'redirected', { Location => $h->{redirect} },
"Redirected to {redirect}\">here"
];
} elsif ($h->{content}) {
$res = [
200, 'ok', { 'Content-Type' => $h->{content}->[0] },
$h->{content}->[1]
];
}
}
$self->{responded} = 1;
my $no_body = $self->method eq 'HEAD';
if (not defined $res) {
$rescb->(404, "ok", { 'Content-Type' => 'text/html' }, "No content
", $no_body);
} else {
$rescb->(@$res, $no_body);
}
}
=item B
Returns true if this request already has been responded to.
=cut
sub responded { $_[0]->{responded} }
=item B
Returns the first value of the form parameter C<$key> or undef.
=cut
sub parm {
my ($self, $key) = @_;
if (exists $self->{parm}->{$key}) {
return $self->{parm}->{$key}->[0]->[0]
}
return undef;
}
=item B
Returns list of parameter names.
=cut
sub params { keys %{$_[0]->{parm} || {}} }
=item B
Returns a hash of form parameters. The value is either the
value of the parameter, and in case there are multiple values
present it will contain an array reference of values.
=cut
sub vars {
my ($self) = @_;
my $p = $self->{parm};
my %v = map {
my $k = $_;
$k =>
@{$p->{$k}} > 1
? [ map { $_->[0] } @{$p->{$k}} ]
: $p->{$k}->[0]->[0]
} keys %$p;
%v
}
=item B
This method returns the method of the current request.
=cut
sub method { $_[0]{method} }
=item B
Returns the request content or undef if only parameters for a form
were transmitted.
=cut
sub content { $_[0]->{content} }
=item B
This method will return a hash reference containing the HTTP headers for this
HTTP request.
=cut
sub headers { $_[0]->{hdr} }
=item B
This method returns the host/IP of the HTTP client this request was received
from.
=cut
sub client_host { $_[0]->{host} }
=item B
This method returns the TCP port number of the HTTP client this
request was received from.
=cut
sub client_port { $_[0]->{port} }
=back
=head1 COPYRIGHT & LICENSE
Copyright 2008-2011 Robin Redeker, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1;
libanyevent-httpd-perl-0.93/lib/AnyEvent/HTTPD/HTTPConnection.pm 0000644 0001750 0001750 00000025051 11616455565 023342 0 ustar dimka dimka package AnyEvent::HTTPD::HTTPConnection;
use common::sense;
use IO::Handle;
use AnyEvent::Handle;
use Object::Event;
use Time::Local;
use AnyEvent::HTTPD::Util;
use Scalar::Util qw/weaken/;
our @ISA = qw/Object::Event/;
=head1 NAME
AnyEvent::HTTPD::HTTPConnection - A simple HTTP connection for request and response handling
=head1 DESCRIPTION
This class is a helper class for L and L,
it handles TCP reading and writing as well as parsing and serializing
http requests.
It has no public interface yet.
=head1 COPYRIGHT & LICENSE
Copyright 2008-2011 Robin Redeker, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = { @_ };
bless $self, $class;
$self->{request_timeout} = 60
unless defined $self->{request_timeout};
$self->{hdl} =
AnyEvent::Handle->new (
fh => $self->{fh},
on_eof => sub { $self->do_disconnect },
on_error => sub { $self->do_disconnect ("Error: $!") },
($self->{ssl}
? (tls => "accept", tls_ctx => $self->{ssl})
: ()),
);
$self->push_header_line;
return $self
}
sub error {
my ($self, $code, $msg, $hdr, $content) = @_;
if ($code !~ /^(1\d\d|204|304)$/o) {
unless (defined $content) { $content = "$code $msg\n" }
$hdr->{'Content-Type'} = 'text/plain';
}
$self->response ($code, $msg, $hdr, $content);
}
sub response_done {
my ($self) = @_;
(delete $self->{transfer_cb})->() if $self->{transfer_cb};
# sometimes a response might be written after connection is already dead:
return unless defined ($self->{hdl}) && !$self->{disconnected};
$self->{hdl}->on_drain; # clear any drain handlers
if ($self->{keep_alive}) {
$self->push_header_line;
} else {
$self->{hdl}->on_drain (sub { $self->do_disconnect });
}
}
our @DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
our @MoY = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
our %MoY;
@MoY{@MoY} = (1..12);
# Taken from HTTP::Date module of LWP.
sub _time_to_http_date
{
my $time = shift;
$time = time unless defined $time;
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time);
sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
$DoW[$wday],
$mday, $MoY[$mon], $year + 1900,
$hour, $min, $sec);
}
sub response {
my ($self, $code, $msg, $hdr, $content, $no_body) = @_;
return if $self->{disconnected};
return unless $self->{hdl};
my $res = "HTTP/1.0 $code $msg\015\012";
header_set ($hdr, 'Date' => _time_to_http_date time)
unless header_exists ($hdr, 'Date');
header_set ($hdr, 'Expires' => header_get ($hdr, 'Date'))
unless header_exists ($hdr, 'Expires');
header_set ($hdr, 'Cache-Control' => "max-age=0")
unless header_exists ($hdr, 'Cache-Control');
header_set ($hdr, 'Connection' =>
($self->{keep_alive} ? 'Keep-Alive' : 'close'));
header_set ($hdr, 'Content-Length' => length "$content")
unless header_exists ($hdr, 'Content-Length')
|| ref $content;
unless (defined header_get ($hdr, 'Content-Length')) {
# keep alive with no content length will NOT work.
delete $self->{keep_alive};
header_set ($hdr, 'Connection' => 'close');
}
while (my ($h, $v) = each %$hdr) {
next unless defined $v;
$res .= "$h: $v\015\012";
}
$res .= "\015\012";
if ($no_body) { # for HEAD requests!
$self->{hdl}->push_write ($res);
$self->response_done;
return;
}
if (ref ($content) eq 'CODE') {
weaken $self;
my $chunk_cb = sub {
my ($chunk) = @_;
return 0 unless defined ($self) && defined ($self->{hdl}) && !$self->{disconnected};
delete $self->{transport_polled};
if (defined ($chunk) && length ($chunk) > 0) {
$self->{hdl}->push_write ($chunk);
} else {
$self->response_done;
}
return 1;
};
$self->{transfer_cb} = $content;
$self->{hdl}->on_drain (sub {
return unless $self;
if (length $res) {
my $r = $res;
undef $res;
$chunk_cb->($r);
} elsif (not $self->{transport_polled}) {
$self->{transport_polled} = 1;
$self->{transfer_cb}->($chunk_cb) if $self;
}
});
} else {
$res .= $content;
$self->{hdl}->push_write ($res);
$self->response_done;
}
}
sub _unquote {
my ($str) = @_;
if ($str =~ /^"(.*?)"$/o) {
$str = $1;
my $obo = '';
while ($str =~ s/^(?:([^"]+)|\\(.))//so) {
$obo .= $1;
}
$str = $obo;
}
$str
}
sub decode_part {
my ($self, $hdr, $cont) = @_;
$hdr = _parse_headers ($hdr);
if ($hdr->{'content-disposition'} =~ /form-data|attachment/o) {
my ($dat, @pars) = split /\s*;\s*/o, $hdr->{'content-disposition'};
my @params;
my %p;
my @res;
for my $name_para (@pars) {
my ($name, $par) = split /\s*=\s*/o, $name_para;
if ($par =~ /^".*"$/o) { $par = _unquote ($par) }
$p{$name} = $par;
}
my ($ctype, $bound) = _content_type_boundary ($hdr->{'content-type'});
if ($ctype eq 'multipart/mixed') {
my $parts = $self->decode_multipart ($cont, $bound);
for my $sp (keys %$parts) {
for (@{$parts->{$sp}}) {
push @res, [$p{name}, @$_];
}
}
} else {
push @res, [$p{name}, $cont, $hdr->{'content-type'}, $p{filename}];
}
return @res
}
();
}
sub decode_multipart {
my ($self, $cont, $boundary) = @_;
my $parts = {};
while ($cont =~ s/
^--\Q$boundary\E \015?\012
((?:[^\015\012]+\015\012)* ) \015?\012
(.*?) \015?\012
(--\Q$boundary\E (--)? \015?\012)
/\3/xs) {
my ($h, $c, $e) = ($1, $2, $4);
if (my (@p) = $self->decode_part ($h, $c)) {
for my $part (@p) {
push @{$parts->{$part->[0]}}, [$part->[1], $part->[2], $part->[3]];
}
}
last if $e eq '--';
}
return $parts;
}
# application/x-www-form-urlencoded
#
# This is the default content type. Forms submitted with this content type must
# be encoded as follows:
#
# 1. Control names and values are escaped. Space characters are replaced by
# `+', and then reserved characters are escaped as described in [RFC1738],
# section 2.2: Non-alphanumeric characters are replaced by `%HH', a percent
# sign and two hexadecimal digits representing the ASCII code of the
# character. Line breaks are represented as "CR LF" pairs (i.e., `%0D%0A').
#
# 2. The control names/values are listed in the order they appear in the
# document. The name is separated from the value by `=' and name/value pairs
# are separated from each other by `&'.
#
sub _content_type_boundary {
my ($ctype) = @_;
my ($c, @params) = split /\s*[;,]\s*/o, $ctype;
my $bound;
for (@params) {
if (/^\s*boundary\s*=\s*(.*?)\s*$/o) {
$bound = _unquote ($1);
}
}
($c, $bound)
}
sub handle_request {
my ($self, $method, $uri, $hdr, $cont) = @_;
$self->{keep_alive} = ($hdr->{connection} =~ /keep-alive/io);
my ($ctype, $bound) = _content_type_boundary ($hdr->{'content-type'});
if ($ctype eq 'multipart/form-data') {
$cont = $self->decode_multipart ($cont, $bound);
} elsif ($ctype =~ /x-www-form-urlencoded/o) {
$cont = parse_urlencoded ($cont);
}
$self->event (request => $method, $uri, $hdr, $cont);
}
# loosely adopted from AnyEvent::HTTP:
sub _parse_headers {
my ($header) = @_;
my $hdr;
$header =~ y/\015//d;
while ($header =~ /\G
([^:\000-\037]+):
[\011\040]*
( (?: [^\012]+ | \012 [\011\040] )* )
\012
/sgcxo) {
$hdr->{lc $1} .= ",$2"
}
return undef unless $header =~ /\G$/sgxo;
for (keys %$hdr) {
substr $hdr->{$_}, 0, 1, '';
# remove folding:
$hdr->{$_} =~ s/\012([\011\040])/$1/sgo;
}
$hdr
}
sub push_header {
my ($self, $hdl) = @_;
$self->{hdl}->unshift_read (line =>
qr{(?error (599 => "garbled headers");
}
push @{$self->{last_header}}, $hdr;
if (defined $hdr->{'content-length'}) {
$self->{hdl}->unshift_read (chunk => $hdr->{'content-length'}, sub {
my ($hdl, $data) = @_;
$self->handle_request (@{$self->{last_header}}, $data);
});
} else {
$self->handle_request (@{$self->{last_header}});
}
}
);
}
sub push_header_line {
my ($self) = @_;
return if $self->{disconnected};
weaken $self;
$self->{req_timeout} =
AnyEvent->timer (after => $self->{request_timeout}, cb => sub {
return unless defined $self;
$self->do_disconnect ("request timeout ($self->{request_timeout})");
});
$self->{hdl}->push_read (line => sub {
my ($hdl, $line) = @_;
return unless defined $self;
delete $self->{req_timeout};
if ($line =~ /(\S+) \040 (\S+) \040 HTTP\/(\d+)\.(\d+)/xso) {
my ($meth, $url, $vm, $vi) = ($1, $2, $3, $4);
if (not grep { $meth eq $_ } @{ $self->{allowed_methods} }) {
$self->error (501, "not implemented",
{ Allow => join(",", @{ $self->{allowed_methods} })});
return;
}
if ($vm >= 2) {
$self->error (506, "http protocol version not supported");
return;
}
$self->{last_header} = [$meth, $url];
$self->push_header;
} elsif ($line eq '') {
# ignore empty lines before requests, this prevents
# browser bugs w.r.t. keep-alive (according to marc lehmann).
$self->push_header_line;
} else {
$self->error (400 => 'bad request');
}
});
}
sub do_disconnect {
my ($self, $err) = @_;
return if $self->{disconnected};
$self->{disconnected} = 1;
$self->{transfer_cb}->() if $self->{transfer_cb};
delete $self->{transfer_cb};
delete $self->{req_timeout};
$self->event ('disconnect', $err);
shutdown $self->{hdl}->{fh}, 1;
$self->{hdl}->on_read (sub { });
$self->{hdl}->on_eof (undef);
my $timer;
$timer = AE::timer 2, 0, sub {
undef $timer;
delete $self->{hdl};
};
}
1;
libanyevent-httpd-perl-0.93/lib/AnyEvent/HTTPD.pm 0000644 0001750 0001750 00000030735 11616455535 020545 0 ustar dimka dimka package AnyEvent::HTTPD;
use common::sense;
use Scalar::Util qw/weaken/;
use URI;
use AnyEvent::HTTPD::Request;
use AnyEvent::HTTPD::Util;
use base qw/AnyEvent::HTTPD::HTTPServer/;
=head1 NAME
AnyEvent::HTTPD - A simple lightweight event based web (application) server
=head1 VERSION
Version 0.93
=cut
our $VERSION = '0.93';
=head1 SYNOPSIS
use AnyEvent::HTTPD;
my $httpd = AnyEvent::HTTPD->new (port => 9090);
$httpd->reg_cb (
'/' => sub {
my ($httpd, $req) = @_;
$req->respond ({ content => ['text/html',
"Hello World!
"
. "another test page"
. ""
]});
},
'/test' => sub {
my ($httpd, $req) = @_;
$req->respond ({ content => ['text/html',
"Test page
"
. "Back to the main page"
. ""
]});
},
);
$httpd->run; # making a AnyEvent condition variable would also work
=head1 DESCRIPTION
This module provides a simple HTTPD for serving simple web application
interfaces. It's completly event based and independend from any event loop
by using the L module.
It's HTTP implementation is a bit hacky, so before using this module make sure
it works for you and the expected deployment. Feel free to improve the HTTP
support and send in patches!
The documentation is currently only the source code, but next versions of this
module will be better documented hopefully. See also the C directory
in the L distribution for basic starting points.
=head1 FEATURES
=over 4
=item * support for GET and POST requests.
=item * support for HTTP 1.0 keep-alive.
=item * processing of C and C (C) encoded form parameters.
=item * support for streaming responses.
=item * with version 0.8 no more dependend on L for L.
=item * (limited) support for SSL
=back
=head1 METHODS
The L class inherits directly from
L which inherits the event callback interface from
L.
Event callbacks can be registered via the L API (see the
documentation of L for details).
For a list of available events see below in the I section.
=over 4
=item B
This is the constructor for a L object.
The C<%args> hash may contain one of these key/value pairs:
=over 4
=item host => $host
The TCP address of the HTTP server will listen on. Usually 0.0.0.0 (the
default), for a public server, or 127.0.0.1 for a local server.
=item port => $port
The TCP port the HTTP server will listen on. If undefined some
free port will be used. You can get it via the C method.
=item ssl => $tls_ctx
If this option is given the server will listen for a SSL/TLS connection on the
configured port. As C<$tls_ctx> you can pass anything that you can pass as
C to an L object.
Example:
my $httpd =
AnyEvent::HTTPD->new (
port => 443,
ssl => { cert_file => "/path/to/my/server_cert_and_key.pem" }
);
Or:
my $httpd =
AnyEvent::HTTPD->new (
port => 443,
ssl => AnyEvent::TLS->new (...),
);
=item request_timeout => $seconds
This will set the request timeout for connections.
The default value is 60 seconds.
=item backlog => $int
The backlog argument defines the maximum length the queue of pending
connections may grow to. The real maximum queue length will be 1.5 times more
than the value specified in the backlog argument.
See also C.
By default will be set by LC<::tcp_server> to C<128>.
=item connection_class => $class
This is a special parameter that you can use to pass your own connection class
to L. This is only of interest to you if you plan
to subclass L.
=item request_class => $class
This is a special parameter that you can use to pass your own request class
to L. This is only of interest to you if you plan
to subclass L.
=item allowed_methods => $arrayref
This parameter sets the allowed HTTP methods for requests, defaulting to GET,
HEAD and POST. Each request received is matched against this list, and a
'501 not implemented' is returned if no match is found. Requests using
disallowed handlers will never trigger callbacks.
=back
=cut
sub new {
my $this = shift;
my $class = ref($this) || $this;
my $self = $class->SUPER::new (
request_class => "AnyEvent::HTTPD::Request",
@_
);
$self->reg_cb (
connect => sub {
my ($self, $con) = @_;
weaken $self;
$self->{conns}->{$con} = $con->reg_cb (
request => sub {
my ($con, $meth, $url, $hdr, $cont) = @_;
#d# warn "REQUEST: $meth, $url, [$cont] " . join (',', %$hdr) . "\n";
$url = URI->new ($url);
if ($meth eq 'GET') {
$cont = parse_urlencoded ($url->query);
}
if ( scalar grep { $meth eq $_ } @{ $self->{allowed_methods} } ) {
weaken $con;
$self->handle_app_req (
$meth, $url, $hdr, $cont, $con->{host}, $con->{port},
sub {
$con->response (@_) if $con;
});
} else {
$con->response (200, "ok");
}
}
);
$self->event (client_connected => $con->{host}, $con->{port});
},
disconnect => sub {
my ($self, $con) = @_;
$con->unreg_cb (delete $self->{conns}->{$con});
$self->event (client_disconnected => $con->{host}, $con->{port});
},
);
$self->{state} ||= {};
return $self
}
sub handle_app_req {
my ($self, $meth, $url, $hdr, $cont, $host, $port, $respcb) = @_;
my $req =
$self->{request_class}->new (
httpd => $self,
method => $meth,
url => $url,
hdr => $hdr,
parm => (ref $cont ? $cont : {}),
content => (ref $cont ? undef : $cont),
resp => $respcb,
host => $host,
port => $port,
);
$self->{req_stop} = 0;
$self->event (request => $req);
return if $self->{req_stop};
my @evs;
my $cururl = '';
for my $seg ($url->path_segments) {
$cururl .= $seg;
push @evs, $cururl;
$cururl .= '/';
}
for my $ev (reverse @evs) {
$self->event ($ev => $req);
last if $self->{req_stop};
}
}
=item B
Returns the port number this server is bound to.
=item B
Returns the host/ip this server is bound to.
=item B
Returns an arrayref of allowed HTTP methods, possibly as set by the
allowed_methods argument to the constructor.
=item B
When the server walks the request URI path upwards you can stop
the walk by calling this method. You can even stop further handling
after the C event.
Example:
$httpd->reg_cb (
'/test' => sub {
my ($httpd, $req) = @_;
# ...
$httpd->stop_request; # will prevent that the callback below is called
},
'' => sub { # this one wont be called by a request to '/test'
my ($httpd, $req) = @_;
# ...
}
);
=cut
sub stop_request {
my ($self) = @_;
$self->{req_stop} = 1;
}
=item B
This method is a simplification of the C condition variable
idiom. You can use it instead of writing:
my $cvar = AnyEvent->condvar;
$cvar->wait;
=cut
sub run {
my ($self) = @_;
$self->{condvar} = AnyEvent->condvar;
$self->{condvar}->wait;
}
=item B
This will stop the HTTP server and return from the
C method B
=cut
sub stop { $_[0]->{condvar}->broadcast if $_[0]->{condvar} }
=back
=head1 EVENTS
Every request goes to a specific URL. After a (GET or POST) request is
received the URL's path segments are walked down and for each segment
a event is generated. An example:
If the URL '/test/bla.jpg' is requestes following events will be generated:
'/test/bla.jpg' - the event for the last segment
'/test' - the event for the 'test' segment
'' - the root event of each request
To actually handle any request you just have to register a callback for the event
name with the empty string. To handle all requests in the '/test' directory
you have to register a callback for the event with the name C<'/test'>.
Here is an example how to register an event for the example URL above:
$httpd->reg_cb (
'/test/bla.jpg' => sub {
my ($httpd, $req) = @_;
$req->respond ([200, 'ok', { 'Content-Type' => 'text/html' }, 'Test
' }]);
}
);
See also C about stopping the walk of the path segments.
The first argument to such a callback is always the L object
itself. The second argument (C<$req>) is the L
object for this request. It can be used to get the (possible) form parameters
for this request or the transmitted content and respond to the request.
Along with the above mentioned events these events are also provided:
=over 4
=item request => $req
Every request also emits the C event, with the same arguments and
semantics as the above mentioned path request events. You can use this to
implement your own request multiplexing. You can use C to stop
any further processing of the request as the C event is the first
thing that is executed for an incoming request.
An example of one of many possible uses:
$httpd->reg_cb (
request => sub {
my ($httpd, $req) = @_;
my $url = $req->url;
if ($url->path =~ /\/images\/img_(\d+).jpg$/) {
handle_image_request ($req, $1); # your task :)
# stop the request from emitting further events
# so that the '/images/img_001.jpg' and the
# '/images' and '' events are NOT emitted:
$httpd->stop_request;
}
}
);
=item client_connected => $host, $port
=item client_disconnected => $host, $port
These events are emitted whenever a client coming from C<$host:$port> connects
to your server or is disconnected from it.
=back
=head1 CACHING
Any response from the HTTP server will have C set to C and
also the C header set to the C header. Meaning: Caching is disabled.
You can of course set those headers yourself in the response, or remove them by
setting them to undef, but keep in mind that the default for those headers are
like mentioned above.
If you need more support here you can send me a mail or even better: a patch :)
=head1 AUTHOR
Robin Redeker, C<< >>
=head1 BUGS
Please report any bugs or feature requests to C,
or through the web interface at
L. I will be
notified, and then you'll automatically be notified of progress on your bug as
I make changes.
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc AnyEvent::HTTPD
You can also look for information at:
=over 4
=item * Git repository
L
=item * RT: CPAN's request tracker
L
=item * AnnoCPAN: Annotated CPAN documentation
L
=item * CPAN Ratings
L
=item * Search CPAN
L
=back
=head1 ACKNOWLEDGEMENTS
Andrey Smirnov - for keep-alive patches.
Pedro Melo - for valuable input in general and patches.
Nicholas Harteau - patch for ';' pair separator support,
patch for allowed_methods support
Chris Kastorff - patch for making default headers removable
and more fault tolerant w.r.t. case.
Mons Anderson - Optimizing the regexes in L
and adding the C option to L.
=head1 COPYRIGHT & LICENSE
Copyright 2008-2011 Robin Redeker, all rights reserved.
This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
=cut
1; # End of AnyEvent::HTTPD