package HTTP::Server::Brick;
use version;
our $VERSION = qv(0.1.4);
# $Id$
=head1 NAME
HTTP::Server::Brick - Simple pure perl http server for prototyping "in the style of" Ruby's WEBrick
=head1 VERSION
This document describes HTTP::Server::Brick version 0.1.4
=head1 SYNOPSIS
use HTTP::Server::Brick;
use HTTP::Status;
my $server = HTTP::Server::Brick->new( port => 8888 );
$server->mount( '/foo/bar' => {
path => '/some/directory/htdocs',
});
$server->mount( '/test/proc' => {
handler => sub {
my ($req, $res) = @_;
$res->add_content("<html><body>
<p>Path info: $req->{path_info}</p>
</body></html>");
1;
},
wildcard => 1,
});
$server->mount( '/test/proc/texty' => {
handler => sub {
my ($req, $res) = @_;
$res->add_content("flubber");
$res->header('Content-type', 'text/plain');
1;
},
wildcard => 1,
});
# these next two are equivalent
$server->mount( '/favicon.ico' => {
handler => sub { RC_NOT_FOUND },
});
$server->mount( '/favicon.ico' => {
handler => sub {
my ($req, $res) = @_;
$res->code(RC_NOT_FOUND);
1;
},
});
# start accepting requests (won't return unless/until process
# receives a HUP signal)
$server->start;
For an SSL (https) server, replace the C<new()> line above with:
use HTTP::Daemon::SSL;
my $server = HTTP::Server::Brick->new(
port => 8889,
daemon_class => 'HTTP::Daemon::SSL',
daemon_args => [
SSL_key_file => 'my_ssl_key.pem',
SSL_cert_file => 'my_ssl_cert.pem',
],
);
See the docs of L<HTTP::Daemon::SSL> for other options.
=head1 DESCRIPTION
HTTP::Server::Brick allows you to quickly wrap a prototype web server around some
Perl code. The underlying server daemon is HTTP::Daemon and the performance should
be fine for demo's, light internal systems, etc.
=head1 METHODS
=cut
use warnings;
use strict;
use HTTP::Daemon;
use HTTP::Status;
use LWP::MediaTypes;
use URI;
use constant DEBUG => $ENV{DEBUG} || 0;
my $__singleton;
my $__server_should_run = 0;
$SIG{__WARN__} = sub { $__singleton ? $__singleton->_log( error => '[warn] ' . shift ) : CORE::warn(@_) };
$SIG{__DIE__} = sub {
CORE::die (@_) if $^S; # don't interfere with eval
$__singleton->_log( error => '[die] ' . $_[0] ) if $__singleton;
CORE::die (@_)
};
$SIG{HUP} = sub { $__server_should_run = 0; };
=head2 new
C<new> takes nine named arguments (all of which are optional):
=over
=item error_log, access_log
Should be self-explanatory - can be anything that responds to C<print> eg.
file handle, IO::Handle, etc. Default to stderr and stdout respectively.
=item port
The port to listen on. Defaults to a random high port (you'll see it in the error log).
=item host
The server hostname. Defaults to something sensible.
=item timeout
Used for various timout values - see L<HTTP::Daemon> for more information.
=item directory_index_file
The filename for directory indexing. Note that this only applies to static path mounts.
Defaults to C<index.html>.
=item directory_indexing
If no index file is available (for a static path mount), do you want a clickable list
of files in the directory be rendered? Defaults to true.
=item leave_sig_pipe_handler_alone
HTTP::Daemon, the http server module this package is built on, chokes in certain multiple-request
situations unless you ignore PIPE signals. By default PIPE signals are ignored as soon as you start
the server (and restored if the server exits via HUP). If you want to handle PIPE signals your own
way, pass in a true value for this.
If this makes no sense to you, just ignore it - the "right thing" will happen by default.
=item daemon_class
The class which actually handles webserving. The default is C<HTTP::Daemon>.
If you want SSL, use C<HTTP::Daemon::SSL>. Whatever class you use must inherit
from HTTP::Daemon.
=item daemon_args
Sometimes you need to pass extra arguments to your C<daemon_class>, e.g. SSL
configuration. This arrayref will be dereferenced and passed to C<new>.
=back
=cut
sub new {
my ($this, %args) = @_;
my $class = ref($this) || $this;
if ($args{daemon_class} and not
eval { $args{daemon_class}->isa('HTTP::Daemon') }) {
die "daemon_class argument '$args{daemon_class}'" .
" must inherit from HTTP::Daemon";
}
my $self = bless {
_site_map => [],
error_log => \*STDERR,
access_log => \*STDOUT,
directory_index_file => 'index.html',
directory_indexing => 1,
daemon_class => 'HTTP::Daemon',
daemon_args => [],
%args,
}, $class;
$__singleton = $self;
return $self;
}
=head2 mount
C<mount> takes two positional arguments. The first a full uri (as
a string beginning with '/' - any trailing '/' will be stripped). The
second is a hashref which serves as a spec for the mount. The allowable
hash keys in this spec are:
=over
=item path
A full path to a local filesystem directory or file for static serving.
Mutually exclusive with C<handler>.
=item handler
A coderef. See L</Handlers> below. Mutually exclusive with C<path>.
=item wildcard
If false, only exact matches will be served. If true, any requests based
on the uri will be served. eg. if C<wildcard> is false, C<'/foo/bar'> will
only match C<http://mysite.com/foo/bar> and not, say, C<http://mysite.com/foo/bar/sheep>.
If C<wildcard> is true, on the other hand, it will match. A handler can
access the path extension as described below in L</Handlers>.
Static handlers that are directories default to wildcard true.
=back
The site map is always searched depth-first, in other words a more specific
uri will trump a less-specific one.
=cut
sub mount {
my ($self, $uri, $args) = @_;
ref($args) eq 'HASH' or die 'third arg to mount must be a hashref';
my $depth;
if ($uri eq '/') {
$depth = 0;
} else {
$uri =~ s!/$!!;
my @parts = split( m!/!, $uri );
$depth = scalar(@parts) - 1; # leading / adds one
}
$self->{_site_map}[$depth] ||= {};
$self->{_site_map}[$depth]{$uri} = $args;
# we should default a static path to a wildcard mount if it's a directory
if (!exists $args->{wildcard} && exists $args->{path} && -d $args->{path}) {
$args->{wildcard} = 1;
}
my $mount_type = exists $args->{handler} ? 'handler' :
exists $args->{path} ? 'directory' : '(unknown)';
$self->_log( error => 'Mounted' . ($args->{wildcard} ? ' wildcard' : '') . " $mount_type at $uri" );
1;
}
=head2 start
Actually starts the server - this will loop indefinately, or until
the process recieves a C<HUP> signal in which case it will return after servicing
any current request, or waiting for the next timeout (which defaults to 5s - see L</new>).
=cut
sub start {
my $self = shift;
$__server_should_run = 1;
# HTTP::Daemon chokes on multiple simultaneous requests
unless ($self->{leave_sig_pipe_handler_alone}) {
$self->{_old_sig_pipe_handler} = $SIG{'PIPE'};
$SIG{'PIPE'} = 'IGNORE';
}
$SIG{CHLD} = 'IGNORE' if $self->{fork};
$self->{daemon} = $self->{daemon_class}->new(
ReuseAddr => 1,
LocalPort => $self->{port},
LocalHost => $self->{host},
Timeout => 5,
@{ $self->{daemon_args} },
) or die "Can't start daemon: $!";
# HTTP::Server::Daemon seems inconsistent in returning a string vs URI object
my $url_string = UNIVERSAL::can($self->{daemon}->url, 'as_string') ?
$self->{daemon}->url->as_string :
$self->{daemon}->url;
$self->_log(error => "Server started on $url_string");
while ($__server_should_run) {
my $conn = $self->{daemon}->accept or next;
# if we're a forking server, fork. The parent will wait for the next request.
# TODO: limit number of children
next if $self->{fork} and fork;
while (my $req = $conn->get_request) {
# Provide an X-Brick-Remote-IP header
my ($r_port, $r_iaddr) = Socket::unpack_sockaddr_in($conn->peername);
my $ip = Socket::inet_ntoa($r_iaddr);
$req->headers->remove_header('X-Brick-Remote-IP');
$req->header('X-Brick-Remote-IP' => $ip) if defined $ip;
my ($submap, $match) = $self->_map_request($req);
if ($submap) {
if (exists $submap->{path}) {
$self->_handle_static_request( $conn, $req, $submap, $match);
} elsif (exists $submap->{handler}) {
$self->_handle_dynamic_request( $conn, $req, $submap, $match);
} else {
$self->_send_error($conn, $req, RC_INTERNAL_SERVER_ERROR, 'Corrupt Site Map');
}
} else {
$self->_send_error($conn, $req, RC_NOT_FOUND, ' Not Found in Site Map');
}
}
# should use a guard object here to protect against early exit leaving zombies
exit if $self->{fork};
}
unless ($self->{leave_sig_pipe_handler_alone}) {
$SIG{'PIPE'} = $self->{_old_sig_pipe_handler};
}
1;
}
sub _handle_static_request {
my ($self, $conn, $req, $submap, $match) = @_;
my $path = $submap->{path} . '/' . $match->{path_info};
if (-d $path && $match->{full_path} !~ m!/$! ) {
$conn->send_redirect( $match->{full_path} . '/', RC_SEE_OTHER );
DEBUG && $self->_log(error => 'redirecting to path with / appended: ' . $match->{full_path});
return;
}
my $serve_path = -d $path ? "$path/$self->{directory_index_file}" : $path;
if (-r $serve_path) {
my $code = $conn->send_file_response($serve_path);
$self->_log_status($req, $code);
} elsif (-d $path && $self->{directory_indexing}) {
my $res = $self->_render_directory($path, $match->{full_path});
$conn->send_response( $res );
$self->_log( access => '[' . RC_OK . "] $match->{full_path}" );
} elsif (-d $path) {
$self->_send_error($conn, $req, RC_FORBIDDEN, 'Directory Indexing Not Allowed' );
} else {
$self->_send_error($conn, $req, RC_NOT_FOUND, 'File Not Found' );
}
}
sub _handle_dynamic_request {
my ($self, $conn, $req, $submap, $match) = @_;
my $res = HTTP::Response->new;
$res->base($match->{full_path});
# stuff the match info into the request
$req->{mount_path} = $match->{mount_path};
$req->{path_info} = $match->{path_info} ? '/' . $match->{path_info} : undef;
# and some other useful bits TODO: document (and, actually, subclass HTTP::Request...)
# It seems that in some cases (specifically when the url contains no explicit port),
# HTTP::Daemon returns a uri string instead of an object. RT #29042
my $url = $self->{daemon}->url;
$url = URI->new($url) if ! ref $url;
if ($req->header('Host') =~ /^(.*):(.*)$/) {
$req->{hostname} = $1;
$req->{port} = $2;
} elsif ($req->header('Host')) {
$req->{hostname} = $req->header('Host');
$req->{port} = $url->port;
} else {
$req->{hostname} = $url->host;
$req->{port} = $url->port;
}
# actually call the handler
if ( my $return_code = eval { $submap->{handler}->($req, $res) } ) {
# choose the status in this order:
# 1. if the handler died or returned false => RC_INTERNAL_SERVER_ERROR
# 2. if the handler set a code on the response object, use that
# 3. if the handler returned something that looks like a return code
# 4. RC_OK
my $code = !$return_code ? RC_INTERNAL_SERVER_ERROR :
$res->code ? $res->code :
$return_code >= 100 ? $return_code : RC_OK;
$res->code($code);
# default mime type to text/html
$res->header( 'Content-Type' ) || $res->header( 'Content-Type', 'text/html' );
if ($res->is_success) {
$conn->send_response( $res );
$self->_log( access => "[$code] $match->{full_path}" );
} elsif ($res->is_error) {
# TODO: should allow a way to specify custom error content
$self->_send_error( $conn, $req, $res->code, $res->message );
} elsif ($res->is_redirect) {
if (UNIVERSAL::can($res->{target_uri}, 'path')) {
my $target = $res->{target_uri}->path;
if ($target !~ m!^/!) {
# prepend dirname of original request
$match->{full_path} =~ m!^(.*/)! and
$target = $1 . $target;
}
$conn->send_redirect($target, $code);
$self->_log( access => "[$code] Redirecting to " . $target );
} else {
$self->_send_error($conn, $req, RC_INTERNAL_SERVER_ERROR,
'Handler Tried to Redirect Without Setting Target URI');
}
} else {
$self->_send_error($conn, $req,
RC_NOT_IMPLEMENTED,
'Handler Returned an Unimplemented Response Code: ' . $code);
}
} else {
$self->_send_error($conn, $req, RC_INTERNAL_SERVER_ERROR, 'Handler Failed');
$self->_log( error => "Handler Failed for mount: " . $match->{mount_path});
$self->_log( error => $@ ) if $@;
}
1;
}
sub _render_directory {
my ($self, $path, $uri ) = @_;
my $res = HTTP::Response->new( RC_OK );
$res->header( 'Content-type', 'text/html' );
$res->add_content(<<END_HEADER);
<html>
<head>
<title>Directory for $uri</title>
</head>
<body>
<h1>Directory for $uri</h1>
<blockquote><pre>
<a href="..">.. (Parent directory)</a>
END_HEADER
$res->add_content("<a href=\"$_\">$_</a>\n") for map {s!.*/!!; $_} sort glob "$path/*";
$res->add_content(<<END_FOOTER);
</pre></blockquote>
</body>
</html>
END_FOOTER
return $res;
}
sub _send_error {
my ($self, $conn, $req, $code, $text) = @_;
$conn->send_error($code, $text);
$self->_log_status($req, $code, $text);
}
sub _log_status {
my ($self, $req, $code, $text) = @_;
if ($code == RC_OK || $code == RC_UNAUTHORIZED || $code == RC_NOT_FOUND) {
$self->_log( access => "[$code] " . $req->uri->path );
}
$self->_log( error => "[$code] [" . $req->uri->path . '] ' . ($text || status_message($code)) )
unless $code == RC_OK;
}
# this is not the best data structure for a complex site map, but it's
# easy to insert and query (although very hard to move things around).
# basically for every path depth (ie. number of /) there is a hash of
# full paths and their associated handler and meta-data.
# this would be an obvious performance point if you wanted to use this
# for actual serving.
sub _map_request {
my ($self, $request) = @_;
my $map = $self->{_site_map};
my $uri = $request->uri->path;
my @parts = split( m!/!, $uri );
my $depth = scalar(@parts) - 1;
# the test is reall for $uri eq '/', but an integer comparison is faster
$depth = 0 if $depth == -1;
my $match_depth = $depth;
while ($match_depth >= 0) {
my $mount_path = '/' . join('/', @parts[1..$match_depth]);
if ($map->[$match_depth] && exists $map->[$match_depth]{$mount_path}) {
# if we find a depth-first match, but it's not flagged as a wildcard
# mount, then don't match
if ($match_depth != $depth && !$map->[$match_depth]{$mount_path}{wildcard}) {
return;
}
return(
$map->[$match_depth]{$mount_path},
{
full_path => $uri,
mount_path => $mount_path,
path_info => join('/', @parts[$match_depth+1..$depth]),
},
);
}
$match_depth--;
}
}
=head2 add_type
The mime-type of static files is automatically determined by L<LWP::MediaTypes>. You
can add any types it doesn't know about via this method.
The first argument is the mime type, all subsequent arguments form a list of
possible file extensions for that mime type. See L<LWP::MediaTypes> for more info.
=cut
# Improve LWP::MediaTypes' mime-type knowledge.
LWP::MediaTypes::add_type('image/png' => qw(png));
LWP::MediaTypes::add_type('text/css' => qw(css));
LWP::MediaTypes::add_type('text/javascript' => qw(js));
sub add_type {
my ($self, @args) = @_;
LWP::MediaTypes::add_type(@args);
}
sub _log {
my ($self, $log_key, $text) = @_;
$self->{"${log_key}_log"}->print( '[' . localtime() . "] [$$] ", $text, "\n" );
}
1; # Magic true value required at end of module
__END__
=head1 Handlers
When a mounted handler codred matches a requested url, the sub is called with two
arguments in C<@_>, first a request object then a response object.
=head2 Request
The request object is an instance of L<HTTP::Request> with two extra properties:
=over
=item C<$req-E<gt>{mount_path}>
The mounted path that was matched. This will always be identical to C<< $req->uri->path >>
for non-wildcard mounts.
=item C<$req-E<gt>{path_info}>
Using nomenclature from L<CGI.pm>, any extra path (or rather, uri) info after the matched C<mount_path>.
This will always be empty for non-wildcard mounts.
=back
The documentation for L<HTTP::Request> will be of use for extracting all the other
useful information.
Added to the regular request headers created by L<HTTP::Request> is an X-Remote-IP header,
which allows you to obtain the remote IP of the client. (Contributed by Hans Dieter Pearcey).
=head2 Response
The response object is an instance of L<HTTP::Response>. The useful operations (which
you can learn how to do from the L<HTTP::Response> docs) are setting headers,
adding content and setting the http status code.
=head2 Response Headers
The C<Content-type> header defaults to C<text/html> unless your handler sets it to
something else. The C<Content-length> header is set for you.
=head2 Redirection
If you set the response code to a redirect code, you need to set a C<{target_uri}> property on the
request object to an instance of a C<URI::http> object reflecting the uri you want to redirect to
(either fully qualified or relative to the directory of the requested url). There are examples
in the test file C<t/serving.t> in this module's distribution.
This is weak because we're breaking encapsulation by assuming it's ok to stuff an extra variable
into the response object (just as we are to propogate the C<path_info> property). It does in fact
work fine and is unlikely to ever break, but a future version (prior to 1.0.0) of this module will
replace this behavior with a subclassed L<HTTP::Response> and appropriate setter/getter methods.
=head2 Handler Return
The handler sub must return true for a normal response. The actual http response
is determined as follows:
1. if the handler died or returned false => RC_INTERNAL_SERVER_ERROR (ie. 500)
2. if the handler set a code on the response object, use that
3. if the handler returned something that looks like a return code
4. RC_OK (ie. 200)
=head1 DEBUGGING
If an envronment variable DEBUG is set (to something Perl considers true) there will
be extra logging to C<error_log>.
=head1 DEPENDENCIES
L<LWP>
L<Test::More>
L<version>
=head1 HISTORY
Over the past few years I've spent quite a bit of time noodling about with Ruby
based web code - whether Rails or super cool continuation stuff - and it's always
easy to get a prototype up and serving thanks to WEBrick (the pure-Ruby server
that's part of the standard Ruby distribution). I've never found it quite as easy
to throw together such a prototype in Perl, hence YASHDM (yet another simple http
daemon module).
HTTP::Server::Brick is not a clone of WEBrick - it's "in the style of" WEBrick like
those movies in the discount VHS bin are "in the style of Lassie": The good guys
get saved, the bad guys get rounded up, but the dog's never quite as well trained...
To be more fair, I have just taken the ideas I have used (and liked) when building
prototypes with WEBrick and implemented them in (what I hope is) a Perlish way.
=head1 BUGS AND LIMITATIONS
=over
=item It's version 0.1.4 - there's bound to be some bugs!
=item The tests fail on windows due to forking limitations. I don't see any reason why the server itself won't work but I haven't tried it personally, and I have to figure out a way to test it from a test script that will work on Windows.
=item In forking mode there is no attempt to limit the number of forked children - beware of forking yourself ;)
=item No attention has been given to propagating any exception text into the http error (although the exception/die message will appear in the error_log).
=item Versions 1.02 and earlier of HTTP::Daemon::SSL has a feature/documentation conflict where it will never timeout. This means your server won't respond to a HUP signal until the next request is served. Version 1.03_01 (developer release) and later do not have this issue.
=back
If you want to check out the latest development version of HTTP::Server::Brick
you can do so from my GitHub account L<http://github.com/aufflick/p5-http-server-brick>.
Please report any bugs or feature requests to
C<bug-http-server-brick@rt.cpan.org>, through the web interface at
L<http://rt.cpan.org> or via email to the author.
=head1 SEE ALSO
CPAN has various other modules that may suit you better. Search for HTTP::Server or HTTP::Daemon.
L<HTTP::Daemon>, L<HTTP::Daemon::App> and L<HTTP::Server::Simple> spring to mind.
=head1 AUTHOR
=over
=item Original version by: Mark Aufflick C<< <mark@aufflick.com> >> L<http://mark.aufflick.com/>
=item SSL and original forking support by: Hans Dieter Pearcey C<< <hdp@pobox.com> >>
=item Maintained by: Mark Aufflick
=back
=head1 LICENCE AND COPYRIGHT
Copyright (c) 2007 2008, Mark Aufflick C<< <mark@aufflick.com> >>.
Portions Copyright (c) 2007 2008, Hans Dieter Pearcey C<< <hdp@pobox.com> >>
All rights reserved.
This module is free software; you can redistribute it and/or
modify it under the same terms as Perl itself. See L<perlartistic>.
=head1 DISCLAIMER OF WARRANTY
BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER
EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE
ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH
YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL
NECESSARY SERVICING, REPAIR, OR CORRECTION.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE
LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL,
OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE
THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING
RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A
FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF
SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.