package HTTP::Server::Brick;
use version;
our $VERSION = qv('0.1.0');
# $Id: Brick.pm,v 1.23 2007/07/24 09:54:46 aufflick Exp $
=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.0
=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("
Path info: $req->{path_info}
");
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 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 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 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 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 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 for more information.
=item directory_index_file
The filename for directory indexing. Note that this only applies to static path mounts.
Defaults to C.
=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.
If you want SSL, use C. Whatever class you use must inherit
from HTTP::Daemon.
=item daemon_args
Sometimes you need to pass extra arguments to your C, e.g. SSL
configuration. This arrayref will be dereferenced and passed to C.
=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 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.
=item handler
A coderef. See L below. Mutually exclusive with C.
=item wildcard
If false, only exact matches will be served. If true, any requests based
on the uri will be served. eg. if C is false, C<'/foo/bar'> will
only match C and not, say, C.
If C is true, on the other hand, it will match. A handler can
access the path extension as described below in L.
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 signal in which case it will return after servicing
any current request, or waiting for the next timeout (which defaults to 5s - see L).
=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: $!";
$self->_log(error => "Server started on " . $self->{daemon}->url);
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) {
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...)
if ($req->header('Host') =~ /^(.*):(.*)$/) {
$req->{hostname} = $1;
$req->{port} = $2;
} elsif ($req->header('Host')) {
$req->{hostname} = $req->header('Host');
$req->{port} = $self->{daemon}->url->port;
} else {
$req->{hostname} = $self->{daemon}->url->host;
$req->{port} = $self->{daemon}->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) {
# should send user content and use $@ if provided
$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');
}
1;
}
sub _render_directory {
my ($self, $path, $uri ) = @_;
my $res = HTTP::Response->new( RC_OK );
$res->header( 'Content-type', 'text/html' );
$res->add_content(<
Directory for $uri
Directory for $uri
.. (Parent directory)
END_HEADER
$res->add_content("$_\n") for map {s!.*/!!; $_} sort glob "$path/*";
$res->add_content(<