—package
Mojo::Server::Daemon;
use
Mojo::IOLoop;
use
Mojo::URL;
use
POSIX;
has
[
qw(backlog group silent user)
];
has
inactivity_timeout
=>
sub
{
$ENV
{MOJO_INACTIVITY_TIMEOUT} // 15 };
has
ioloop
=>
sub
{ Mojo::IOLoop->singleton };
has
max_clients
=> 1000;
has
max_requests
=> 25;
sub
DESTROY {
my
$self
=
shift
;
return
unless
my
$loop
=
$self
->ioloop;
$self
->_remove(
$_
)
for
keys
%{
$self
->{connections} || {}};
$loop
->remove(
$_
)
for
@{
$self
->{acceptors} || []};
}
sub
run {
my
$self
=
shift
;
# Signals
$SIG
{INT} =
$SIG
{TERM} =
sub
{
exit
0 };
# Change user/group and start accepting connections
$self
->start->setuidgid->ioloop->start;
}
sub
setuidgid {
my
$self
=
shift
;
# Group
if
(
my
$group
=
$self
->group) {
croak
qq{Group "$group" does not exist}
unless
defined
(
my
$gid
= (
getgrnam
(
$group
))[2]);
POSIX::setgid(
$gid
) or croak
qq{Can't switch to group "$group": $!}
;
}
# User
if
(
my
$user
=
$self
->user) {
croak
qq{User "$user" does not exist}
unless
defined
(
my
$uid
= (
getpwnam
(
$self
->user))[2]);
POSIX::setuid(
$uid
) or croak
qq{Can't switch to user "$user": $!}
;
}
return
$self
;
}
sub
start {
my
$self
=
shift
;
# Resume accepting connections
my
$loop
=
$self
->ioloop;
if
(
my
$acceptors
=
$self
->{acceptors}) {
push
@$acceptors
,
$loop
->acceptor(
delete
$self
->{servers}{
$_
})
for
keys
%{
$self
->{servers}};
}
# Start listening
else
{
$self
->_listen(
$_
)
for
@{
$self
->
listen
} }
$loop
->max_connections(
$self
->max_clients);
return
$self
;
}
sub
stop {
my
$self
=
shift
;
# Pause accepting connections
my
$loop
=
$self
->ioloop;
while
(
my
$id
=
shift
@{
$self
->{acceptors}}) {
my
$server
=
$self
->{servers}{
$id
} =
$loop
->acceptor(
$id
);
$loop
->remove(
$id
);
$server
->stop;
}
return
$self
;
}
sub
_build_tx {
my
(
$self
,
$id
,
$c
) =
@_
;
# Build transaction
my
$tx
=
$self
->build_tx->connection(
$id
);
# Identify
$tx
->res->headers->server(
'Mojolicious (Perl)'
);
# Store connection information
my
$handle
=
$self
->ioloop->stream(
$id
)->handle;
$tx
->local_address(
$handle
->sockhost)->local_port(
$handle
->sockport);
$tx
->remote_address(
$handle
->peerhost)->remote_port(
$handle
->peerport);
# TLS
$tx
->req->url->base->scheme(
'https'
)
if
$c
->{tls};
# Handle upgrades and requests
weaken
$self
;
$tx
->on(
upgrade
=>
sub
{
my
(
$tx
,
$ws
) =
@_
;
$ws
->server_handshake;
$self
->{connections}{
$id
}{ws} =
$ws
;
}
);
$tx
->on(
request
=>
sub
{
my
$tx
=
shift
;
$self
->emit(
request
=>
$self
->{connections}{
$id
}{ws} ||
$tx
);
$tx
->on(
resume
=>
sub
{
$self
->_write(
$id
) });
}
);
# Kept alive if we have more than one request on the connection
$tx
->kept_alive(1)
if
++
$c
->{requests} > 1;
return
$tx
;
}
sub
_close {
my
(
$self
,
$id
) =
@_
;
# Finish gracefully
if
(
my
$tx
=
$self
->{connections}{
$id
}{tx}) {
$tx
->server_close }
# Remove connection
delete
$self
->{connections}{
$id
};
}
sub
_finish {
my
(
$self
,
$id
,
$tx
) =
@_
;
# Always remove connection for WebSockets
return
$self
->_remove(
$id
)
if
$tx
->is_websocket;
# Finish transaction
$tx
->server_close;
# Upgrade connection to WebSocket
my
$c
=
$self
->{connections}{
$id
};
if
(
my
$ws
=
$c
->{tx} =
delete
$c
->{ws}) {
# Successful upgrade
if
(
$ws
->res->code eq
'101'
) {
weaken
$self
;
$ws
->on(
resume
=>
sub
{
$self
->_write(
$id
) });
}
# Failed upgrade
else
{
delete
$c
->{tx};
$ws
->server_close;
}
}
# Close connection if necessary
my
$req
=
$tx
->req;
return
$self
->_remove(
$id
)
if
$req
->error || !
$tx
->keep_alive;
# Build new transaction for leftovers
return
unless
$req
->has_leftovers;
$tx
=
$c
->{tx} =
$self
->_build_tx(
$id
,
$c
);
$tx
->server_read(
$req
->leftovers);
}
sub
_listen {
my
(
$self
,
$listen
) =
@_
;
# Options
my
$url
= Mojo::URL->new(
$listen
);
my
$query
=
$url
->query;
my
$options
= {
address
=>
$url
->host,
backlog
=>
$self
->backlog,
port
=>
$url
->port,
tls_ca
=>
scalar
$query
->param(
'ca'
),
tls_cert
=>
scalar
$query
->param(
'cert'
),
tls_key
=>
scalar
$query
->param(
'key'
)
};
my
$verify
=
$query
->param(
'verify'
);
$options
->{tls_verify} =
hex
$verify
if
defined
$verify
;
delete
$options
->{address}
if
$options
->{address} eq
'*'
;
my
$tls
=
$options
->{tls} =
$url
->protocol eq
'https'
? 1 :
undef
;
# Listen
weaken
$self
;
my
$id
=
$self
->ioloop->server(
$options
=>
sub
{
my
(
$loop
,
$stream
,
$id
) =
@_
;
# Add new connection
my
$c
=
$self
->{connections}{
$id
} = {
tls
=>
$tls
};
warn
"-- Accept (@{[$stream->handle->peerhost]})\n"
if
DEBUG;
# Inactivity timeout
$stream
->timeout(
$self
->inactivity_timeout);
# Events
$stream
->on(
close
=>
sub
{
$self
->_close(
$id
) });
$stream
->on(
error
=>
sub
{
return
unless
$self
;
$self
->app->
log
->error(
pop
);
$self
->_close(
$id
);
}
);
$stream
->on(
read
=>
sub
{
$self
->_read(
$id
=>
pop
) });
$stream
->on(
timeout
=>
sub
{
$self
->app->
log
->debug(
'Inactivity timeout.'
)
if
$c
->{tx} });
}
);
push
@{
$self
->{acceptors} ||= []},
$id
;
# Friendly message
return
if
$self
->silent;
$self
->app->
log
->info(
qq{Listening at "$listen".}
);
$listen
=~ s!//\*!//127.0.0.1!i;
say
"Server available at $listen."
;
}
sub
_read {
my
(
$self
,
$id
,
$chunk
) =
@_
;
# Make sure we have a transaction
my
$c
=
$self
->{connections}{
$id
};
my
$tx
=
$c
->{tx} ||=
$self
->_build_tx(
$id
,
$c
);
# Parse chunk
warn
"-- Server <<< Client (@{[$tx->req->url->to_abs]})\n$chunk\n"
if
DEBUG;
$tx
->server_read(
$chunk
);
# Last keep alive request or corrupted connection
$tx
->res->headers->connection(
'close'
)
if
((
$c
->{requests} || 0) >=
$self
->max_requests) ||
$tx
->req->error;
# Finish or start writing
if
(
$tx
->is_finished) {
$self
->_finish(
$id
,
$tx
) }
elsif
(
$tx
->is_writing) {
$self
->_write(
$id
) }
}
sub
_remove {
my
(
$self
,
$id
) =
@_
;
$self
->ioloop->remove(
$id
);
$self
->_close(
$id
);
}
sub
_write {
my
(
$self
,
$id
) =
@_
;
# Not writing
my
$c
=
$self
->{connections}{
$id
};
return
unless
my
$tx
=
$c
->{tx};
return
unless
$tx
->is_writing;
# Get chunk
return
if
$c
->{writing}++;
my
$chunk
=
$tx
->server_write;
delete
$c
->{writing};
warn
"-- Server >>> Client (@{[$tx->req->url->to_abs]})\n$chunk\n"
if
DEBUG;
# Write chunk
my
$stream
=
$self
->ioloop->stream(
$id
)->
write
(
$chunk
);
# Finish or continue writing
weaken
$self
;
my
$cb
=
sub
{
$self
->_write(
$id
) };
if
(
$tx
->is_finished) {
if
(
$tx
->has_subscribers(
'finish'
)) {
$cb
=
sub
{
$self
->_finish(
$id
,
$tx
) }
}
else
{
$self
->_finish(
$id
,
$tx
);
return
unless
$c
->{tx};
}
}
$stream
->
write
(
''
,
$cb
);
}
1;
=head1 NAME
Mojo::Server::Daemon - Non-blocking I/O HTTP and WebSocket server
=head1 SYNOPSIS
use Mojo::Server::Daemon;
my $daemon = Mojo::Server::Daemon->new(listen => ['http://*:8080']);
$daemon->unsubscribe('request');
$daemon->on(request => sub {
my ($daemon, $tx) = @_;
# Request
my $method = $tx->req->method;
my $path = $tx->req->url->path;
# Response
$tx->res->code(200);
$tx->res->headers->content_type('text/plain');
$tx->res->body("$method request for $path!");
# Resume transaction
$tx->resume;
});
$daemon->run;
=head1 DESCRIPTION
L<Mojo::Server::Daemon> is a full featured, highly portable non-blocking I/O
HTTP and WebSocket server, with C<IPv6>, C<TLS>, C<Comet> (long polling) and
multiple event loop support.
Optional modules L<EV> (4.0+), L<IO::Socket::IP> (0.16+) and
L<IO::Socket::SSL> (1.75+) are supported transparently through
L<Mojo::IOLoop>, and used if installed. Individual features can also be
disabled with the C<MOJO_NO_IPV6> and C<MOJO_NO_TLS> environment variables.
See L<Mojolicious::Guides::Cookbook> for more.
=head1 EVENTS
L<Mojo::Server::Daemon> inherits all events from L<Mojo::Server>.
=head1 ATTRIBUTES
L<Mojo::Server::Daemon> inherits all attributes from L<Mojo::Server> and
implements the following new ones.
=head2 backlog
my $backlog = $daemon->backlog;
$daemon = $daemon->backlog(128);
Listen backlog size, defaults to C<SOMAXCONN>.
=head2 group
my $group = $daemon->group;
$daemon = $daemon->group('users');
Group for server process.
=head2 inactivity_timeout
my $timeout = $daemon->inactivity_timeout;
$daemon = $daemon->inactivity_timeout(5);
Maximum amount of time in seconds a connection can be inactive before getting
closed, defaults to the value of the C<MOJO_INACTIVITY_TIMEOUT> environment
variable or C<15>. Setting the value to C<0> will allow connections to be
inactive indefinitely.
=head2 ioloop
my $loop = $daemon->ioloop;
$daemon = $daemon->ioloop(Mojo::IOLoop->new);
Event loop object to use for I/O operations, defaults to the global
L<Mojo::IOLoop> singleton.
=head2 listen
my $listen = $daemon->listen;
$daemon = $daemon->listen(['https://localhost:3000']);
List of one or more locations to listen on, defaults to the value of the
C<MOJO_LISTEN> environment variable or C<http://*:3000>.
# Listen on IPv6 interface
$daemon->listen(['http://[::1]:4000']);
# Listen on two ports with HTTP and HTTPS at the same time
# Use a custom certificate and key
$daemon->listen(['https://*:3000?cert=/x/server.crt&key=/y/server.key']);
# Or even a custom certificate authority
$daemon->listen(
['https://*:3000?cert=/x/server.crt&key=/y/server.key&ca=/z/ca.crt']);
These parameters are currently available:
=over 4
=item ca
Path to TLS certificate authority file.
=item cert
Path to the TLS cert file, defaults to a built-in test certificate.
=item key
Path to the TLS key file, defaults to a built-in test key.
=item verify
TLS verification mode, defaults to C<0x03>.
=back
=head2 max_clients
my $max = $daemon->max_clients;
$daemon = $daemon->max_clients(1000);
Maximum number of parallel client connections, defaults to C<1000>.
=head2 max_requests
my $max = $daemon->max_requests;
$daemon = $daemon->max_requests(100);
Maximum number of keep alive requests per connection, defaults to C<25>.
=head2 silent
my $silent = $daemon->silent;
$daemon = $daemon->silent(1);
Disable console messages.
=head2 user
my $user = $daemon->user;
$daemon = $daemon->user('web');
User for the server process.
=head1 METHODS
L<Mojo::Server::Daemon> inherits all methods from L<Mojo::Server> and
implements the following new ones.
=head2 run
$daemon->run;
Run server.
=head2 setuidgid
$daemon = $daemon->setuidgid;
Set user and group for process.
=head2 start
$daemon = $daemon->start;
Start accepting connections.
=head2 stop
$daemon = $daemon->stop;
Stop accepting connections.
=head1 DEBUGGING
You can set the C<MOJO_DAEMON_DEBUG> environment variable to get some advanced
diagnostics information printed to C<STDERR>.
MOJO_DAEMON_DEBUG=1
=head1 SEE ALSO
L<Mojolicious>, L<Mojolicious::Guides>, L<http://mojolicio.us>.
=cut