Any-Daemon-HTTP
view release on metacpan or search on metacpan
lib/Any/Daemon/FCGI.pm view on Meta::CPAN
use parent 'IO::Socket::IP';
use warnings;
use strict;
use Log::Report 'any-daemon-http';
use Any::Daemon::FCGI::ClientConn ();
sub new(%)
{ my ($class, %args) = @_;
$args{Listen} ||= 5;
$args{Proto} ||= 'tcp';
$class->SUPER::new(%args);
}
#----------------
#----------------
sub accept(;$)
{ my $self = shift;
my $pkg = shift // 'Any::Daemon::FCGI::ClientConn';
$self->SUPER::accept($pkg);
}
1;
lib/Any/Daemon/FCGI/ClientConn.pm view on Meta::CPAN
( REQUEST_COMPLETE => 0
, CANT_MPX_CONN => 1
, OVERLOADED => 2
, UNKNOWN_ROLE => 3
);
my %server_role_id2name = reverse %server_role_name2id;
my %frame_id2name = reverse %frame_name2id;
sub new($%) { (bless {}, $_[0])->init($_[1]) }
sub init($)
{ my ($self, $args) = @_;
$self->{ADFC_requests} = {};
$self->{ADFC_max_conns} = $args->{max_childs} or panic;
$self->{ADFC_max_reqs} = $args->{max_childs};
$self->{ADFC_select} = my $select = IO::Select->new;
$self->{ADFC_socket} = my $socket = $args->{socket} or panic;
$self->{ADFC_stdin} = \my $stdin;
$self->{ADFC_keep_conn} = 0;
$select->add($socket);
$self;
}
#----------------
sub socket() { shift->{ADFC_socket} }
#----------------
sub _next_record()
{ my $self = shift;
my $leader = $self->_read_chunk(8);
length $leader==8 or return;
my ($version, $type_id, $req_id, $clen, $plen) = unpack 'CCnnC', $leader;
my $body = $self->_read_chunk($clen + $plen);
substr $body, -$plen, $plen, '' if $plen; # remove padding bytes
length $body==$clen or return;
($frame_id2name{$type_id} || 'UNKNOWN_TYPE', $req_id, \$body);
}
sub _reply_record($$$)
{ my ($self, $type, $req_id, $body) = @_;
my $type_id = $frame_name2id{$type} or panic $type;
my $empty = ! length $body; # write one empty frame
while(length $body || $empty)
{ my $chunk = substr $body, 0, MAX_FRAME_SEND, '';
my $size = length $chunk;
my $pad = (-$size) % 8; # advise to pad on 8 bytes
my $frame = pack "CCnnCxa${size}x${pad}"
, FCGI_VERSION, $type_id, $req_id, $size, $pad, $chunk;
lib/Any/Daemon/FCGI/ClientConn.pm view on Meta::CPAN
return unless $! == EAGAIN || $! == EINTR || $! == EWOULDBLOCK;
usleep 1000; # 1 ms
}
last if $empty;
}
}
sub get_request()
{ my $self = shift;
my $requests = $self->{ADFC_requests};
my $reqdata;
### At the moment, we will only support processing of whole requests
# and full replies: no chunking inside the server.
while(1)
{ my ($type, $req_id, $body) = $self->_next_record
or return;
lib/Any/Daemon/FCGI/ClientConn.pm view on Meta::CPAN
info __x"fcgi {id} request from {host}"
, id => $req_id
, host => $remote_host || $remote_ip;
$self->keep_connection
or $self->socket->shutdown(SHUT_RD);
$request;
}
sub send_response($;$)
{ my ($self, $response, $stderr) = @_;
#XXX Net::Async::FastCGI::Request demonstrates how to catch stdout and
#XXX stderr via ties. We don't use that here: cleanly work with
#XXX HTTP::Message objects... errors are logged locally.
my $req_id = $response->request->request_id;
# Simply "Status: " in front of the Response header will make the whole
# message HTTP::Response into a valid CGI response.
lib/Any/Daemon/FCGI/ClientConn.pm view on Meta::CPAN
}
$self->_fcgi_end_request(REQUEST_COMPLETE => $req_id);
$self->keep_connection
or $self->socket->shutdown(SHUT_WR);
$self;
}
sub keep_connection()
{ my $self = shift;
$self->{ADFC_keep_conn} || keys %{$self->{ADFC_requests}}
}
#### MANAGEMENT RECORDS
# have req_id==0
sub _management_record($$)
{ my ($self, $type, $body) = @_;
$type eq 'GET_VALUES' ? $self->_fcgi_get_values($body)
: $self->_fcgi_unknown($body);
}
# Request record FCGI_GET_VALUES may be used by the front-end server to
# collect back_end settings. In Apache, you have to configure it manually.
sub _fcgi_get_values($)
{ my $self = shift;
my %need = $self->_body2hash(shift);
# The maximum number of concurrent transport connections this
# application will accept.
$need{FCGI_MAX_CONNS} = $self->{ADFC_max_conns}
if exists $need{FCGI_MAX_CONNS};
# The maximum number of concurrent requests this application will accept.
$need{FCGI_MAX_REQS} = $self->{ADFC_max_reqs}
lib/Any/Daemon/FCGI/ClientConn.pm view on Meta::CPAN
# concurrent requests over each connection), "1" otherwise.
$need{FCGI_MPXS_CONNS} = 0
if exists $need{FCGI_MPXS_CONNS};
$self->_reply_record(GET_VALUES_RESULT => 0, $self->hash2body(\%need));
}
# Reply record FCGI_UNKNOWN_TYPE is designed for protocol upgrades: to
# respond to unknown record types.
sub _fcgi_unknown($)
{ my ($self, $body) = @_;
$self->_reply_record(UNKNOWN_TYPE => 0, '');
}
# Reply END_REQUEST is used for all ways to close a BEGIN_REQUEST session.
# It depends on the $status code which additionals fields were sent.
sub _fcgi_end_request($$;$)
{ my ($self, $status, $req_id, $rc) = @_;
my $body = pack "nCCCC", $rc || 0, $end_status2id{$status}
, RESERVED, RESERVED, RESERVED;
$self->_reply_record(END_REQUEST => $req_id, $body);
}
# Convert the FGCI request into a full HTTP::Request object
sub _body2hash($$)
{ my ($self, $body) = @_;
my %h;
while(length $$body)
{ my $name_len = $self->_take_encoded_nv($body);
my $value_len = $self->_take_encoded_nv($body);
my $name = substr $$body, 0, $name_len, '';
$h{$name} = substr $$body, 0, $value_len, '';
}
\%h;
}
sub _hash2body($)
{ my ($self, $h) = @_;
my @params;
foreach my $name (sort keys %$h)
{ my $name_len = length $name;
my $val_len = length $h->{$name};
push @params, pack "NNxa{$name_len}xa{$val_len}"
, $name_len, $val_len, $name, $h->{$name};
}
join '', @params;
}
# Numerical values are 1 or 4 bytes. Long when first bit == 1
sub _take_encoded_nv($)
{ my ($self, $body) = @_;
my $short = unpack 'C', substr $$body, 0, 1, '';
$short & 0x80 or return $short;
my $long = pack('C', $short & 0x7F) . substr($$body, 0, 3, '');
unpack 'N', $long;
}
sub _read_chunk($)
{ my ($self, $need) = @_;
my $stdin = $self->{ADFC_stdin};
return substr $$stdin, 0, $need, ''
if length $$stdin > $need;
my $select = $self->{ADFC_select};
while(length $$stdin < $need)
{ $select->can_read or next;
lib/Any/Daemon/FCGI/Request.pm view on Meta::CPAN
$VERSION = '0.30';
use base 'HTTP::Request';
use warnings;
use strict;
use Log::Report 'any-daemon-http';
sub new($)
{ my ($class, $args) = @_;
my $params = $args->{params} or panic;
my $role = $args->{role} or panic;
my @headers;
# Content-Type and Content-Length come specially
push @headers, 'Content-Type' => $params->{CONTENT_TYPE}
if exists $params->{CONTENT_TYPE};
lib/Any/Daemon/FCGI/Request.pm view on Meta::CPAN
$self->{ADFR_params} = $params;
$self->{ADFR_role} = $role;
$self->{ADFR_data} = $args->{data};
$self;
}
#----------------
sub request_id { shift->{ADFR_reqid} }
sub params() { shift->{ADFR_params} }
sub param($) { $_[0]->{ADFR_params}{$_[1]} }
sub role() { shift->{ADFR_role} }
sub data() { shift->{ADFR_data} }
1;
lib/Any/Daemon/HTTP.pm view on Meta::CPAN
use constant # default ports
{ PORT_HTTP => 80
, PORT_HTTPS => 443
};
# To support IPv6, replace ::INET by ::IP
@HTTP::Daemon::ClientConn::ISA = qw(IO::Socket::IP);
sub _to_list($) { ref $_[0] eq 'ARRAY' ? @{$_[0]} : defined $_[0] ? $_[0] : () }
sub init($)
{ my ($self, $args) = @_;
$self->SUPER::init($args);
my $listen = $args->{listen} || $args->{socket} || $args->{host};
my (@sockets, @hosts);
foreach my $conn (_to_list $listen)
{ my ($socket, @host) = $self->_create_socket($conn
, protocol => $args->{protocol}
);
lib/Any/Daemon/HTTP.pm view on Meta::CPAN
$self->addVirtualHost
( name => $host
, aliases => [@hosts, 'default']
, documents => $args->{documents}
, handler => $handler
) if $args->{documents} || $handler;
$self;
}
sub _create_socket($%)
{ my ($self, $listen, %args) = @_;
defined $listen or return;
return ($listen, $listen->sockhost.':'.$listen->sockport)
if blessed $listen && $listen->isa('IO::Socket');
my $port = $listen =~ s/\:([0-9]+)$// ? $1 : PORT_HTTP;
my $host = $listen;
my $proto = $self->{ADH_protocol}
= $args{protocol} || ($port==PORT_HTTPS ? 'HTTPS' : 'HTTP');
lib/Any/Daemon/HTTP.pm view on Meta::CPAN
, address => "$host:$port";
notice __x"got socket after {secs} seconds", secs => $elapse
if $elapse;
($socket, "$listen:$port", $socket->sockhost.':'.$socket->sockport);
}
#----------------
sub sockets() { @{shift->{ADH_sockets}} }
sub hosts() { @{shift->{ADH_hosts}} }
sub protocol() { shift->{ADH_protocol} }
#-------------
sub addVirtualHost(@)
{ my $self = shift;
my $config = @_ > 1 ? +{@_} : !defined $_[0] ? return : shift;
my $vhost;
if(blessed $config && $config->isa('Any::Daemon::HTTP::VirtualHost'))
{ $vhost = $config }
elsif(ref $config eq 'HASH')
{ $vhost = $self->{ADH_vhost_class}->new($config) }
else { error __x"virtual host configuration not a valid object nor HASH" }
info __x"adding virtual host {name}", name => $vhost->name;
$self->{ADH_vhosts}{$_} = $vhost
for $vhost->name, $vhost->aliases;
$vhost;
}
sub addProxy(@)
{ my $self = shift;
my $config = @_ > 1 ? +{@_} : !defined $_[0] ? return : shift;
my $proxy;
if(UNIVERSAL::isa($config, 'Any::Daemon::HTTP::Proxy'))
{ $proxy = $config }
elsif(UNIVERSAL::isa($config, 'HASH'))
{ $proxy = $self->{ADH_proxy_class}->new($config) }
else { error __x"proxy configuration not a valid object nor HASH" }
$proxy->forwardMap
or error __x"proxy {name} has no map, so needs inside vhost"
, name => $proxy->name;
info __x"adding proxy {name}", name => $proxy->name;
push @{$self->{ADH_proxies}}, $proxy;
}
sub removeVirtualHost($)
{ my ($self, $id) = @_;
my $vhost = blessed $id && $id->isa('Any::Daemon::HTTP::VirtualHost')
? $id : $self->virtualHost($id);
defined $vhost or return;
delete $self->{ADH_vhosts}{$_}
for $vhost->name, $vhost->aliases;
$vhost;
}
sub virtualHost($) { $_[0]->{ADH_vhosts}{$_[1]} }
sub proxies() { @{shift->{ADH_proxies}} }
sub findProxy($$$)
{ my ($self, $session, $req, $host) = @_;
my $uri = $req->uri->abs("http://$host");
foreach my $proxy ($self->proxies)
{ my $mapped = $proxy->forwardRewrite($session, $req, $uri) or next;
return ($proxy, $mapped);
}
();
}
#-------------------
sub _connection($$)
{ my ($self, $client, $args) = @_;
my $nr_req = 0;
my $max_req = $args->{max_req_per_conn} ||= 100;
my $start = time;
my $deadline = $start + ($args->{max_time_per_conn} ||= 120);
my $bonus = $args->{req_time_bonus} //= 2;
my $conn;
if($self->protocol eq 'FCGI')
lib/Any/Daemon/HTTP.pm view on Meta::CPAN
$resp->header(Connection => ($close ? 'close' : 'open'));
$conn->send_response($resp);
last if $close;
}
alarm 0;
$nr_req;
}
sub _clean_uri($)
{ my ($self, $uri) = @_;
my $path = $uri->path;
for($path)
{ 1 while s!/[^/.]+/+\.\.(/|\z)!/$1!
|| s!^/\.\.(/|\z)!/$1!
|| s!/{2,}!/! # //
|| s!/\.(/|\z)!/!; # /./
}
$uri->path($path);
}
sub run(%)
{ my ($self, %args) = @_;
my $new_child = $args{new_child} || 'newChild';
$args{new_connection} ||= 'newConnection';
my $vhosts = $self->{ADH_vhosts};
unless(keys %$vhosts)
{ my ($host, @aliases) = $self->hosts;
$self->addVirtualHost(name => $host, aliases => ['default', @aliases]);
}
lib/Any/Daemon/HTTP.pm view on Meta::CPAN
$self->psTitle("$title idle after $conn_count");
}
0;
};
info __x"start running the webserver";
$self->SUPER::run(%args);
}
sub newConnection($)
{ my ($self, $session) = @_;
return $self;
}
sub newChild($)
{ my ($self, $select) = @_;
return $self;
}
sub psTitle($)
{ my ($self, $string) = @_;
$0 = $string if $self->{ADH_show_ps};
}
# HTTP::Daemon methods used by ::ClientConn. We steal that parent role,
# but need to mimic the object a little. The names are not compatible
# with MarkOv's convention, so hidden for the users of this module
sub url() { shift->{ADH_host_base} }
sub product_tokens() {shift->{ADH_server}}
1;
__END__
lib/Any/Daemon/HTTP/Directory.pm view on Meta::CPAN
use File::Spec ();
use File::Basename qw/dirname/;
use POSIX::1003 qw/strftime :fd :fs/;
use HTTP::Status qw/:constants/;
use HTTP::Response ();
use Encode qw/encode/;
use MIME::Types ();
my $mimetypes = MIME::Types->new(only_complete => 1);
sub _filename_trans($$);
sub init($)
{ my ($self, $args) = @_;
$self->SUPER::init($args);
my $path = $self->path;
my $loc = $args->{location}
or error __x"directory definition requires location";
my $trans;
if(ref $loc eq 'CODE')
{ $trans = $loc;
lib/Any/Daemon/HTTP/Directory.pm view on Meta::CPAN
my $if = $args->{index_file};
my @if = ref $if eq 'ARRAY' ? @$if
: defined $if ? $if
: qw/index.html index.htm/;
$self->{ADHD_indexfns} = \@if;
$self;
}
#-----------------
sub location() {shift->{ADHD_location}}
sub charset() {shift->{ADHD_charset}}
#-----------------
#-----------------------
sub filename($) { $_[0]->{ADHD_fn}->($_[1]) }
sub _filename_trans($$)
{ my ($path, $loc) = @_;
return $loc if ref $loc eq 'CODE';
sub
{ my $x = shift;
$x =~ s!^\Q$path!$loc! or panic "path $x not inside $path";
$x;
};
}
sub _collect($$$$)
{ my ($self, $vhost, $session, $req, $uri) = @_;
my $item = $self->filename($uri);
# soft-fail when the item does not exists
-e $item or return;
return $self->_file_response($req, $item)
if -f _;
lib/Any/Daemon/HTTP/Directory.pm view on Meta::CPAN
{ -f $item.$if or next;
return $self->_file_response($req, $item.$if);
}
$self->{ADHD_dirlist}
or return HTTP::Response->new(HTTP_FORBIDDEN, "no directory lists");
$self->_list_response($req, $uri, $item);
}
sub _file_response($$)
{ my ($self, $req, $fn) = @_;
-f $fn
or return HTTP::Response->new(HTTP_NOT_FOUND);
open my $fh, '<:raw', $fn
or return HTTP::Response->new(HTTP_FORBIDDEN);
my ($dev, $inode, $mtime) = (stat $fh)[0,1,9];
my $etag = "$dev-$inode-$mtime";
lib/Any/Daemon/HTTP/Directory.pm view on Meta::CPAN
}
$head->content_type($ct);
$head->last_modified($mtime);
$head->header(ETag => $etag);
local $/;
HTTP::Response->new(HTTP_OK, undef, $head, <$fh>);
}
sub _list_response($$$)
{ my ($self, $req, $uri, $dir) = @_;
no warnings 'uninitialized';
my $list = $self->list($dir);
my $now = localtime;
my @rows;
push @rows, <<__UP if $dir ne '/';
<tr><td colspan="5"> </td><td><a href="../">(up)</a></td></tr>
lib/Any/Daemon/HTTP/Directory.pm view on Meta::CPAN
my %filetype =
( &S_IFSOCK => 's', &S_IFLNK => 'l', &S_IFREG => '-', &S_IFBLK => 'b'
, &S_IFDIR => 'd', &S_IFCHR => 'c', &S_IFIFO => 'p');
my @flags = ('---', '--x', '-w-', '-wx', 'r--', 'r-x', 'rw-', 'rwx');
my @stat_fields =
qw/dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks/;
sub list($@)
{ my ($self, $dirname, %opts) = @_;
opendir my $from_dir, $dirname
or return;
my $names = $opts{names} || qr/^[^.]/;
my $prefilter
= ref $names eq 'Regexp' ? sub { $_[0] =~ $names }
: ref $names eq 'CODE' ? $names
: panic "::Directory::list(names) must be regexp or code, not $names";
lib/Any/Daemon/HTTP/Proxy.pm view on Meta::CPAN
use warnings;
use strict;
use Log::Report 'any-daemon-http';
use LWP::UserAgent ();
use HTTP::Status qw(HTTP_TOO_MANY_REQUESTS);
use Time::HiRes qw(time);
sub init($)
{ my ($self, $args) = @_;
$self->SUPER::init($args);
$self->{ADHDP_ua} = $args->{user_agent}
|| LWP::UserAgent->new(keep_alive => 30);
$self->{ADHDP_via} = $args->{via};
if(my $fm = $args->{forward_map})
{ $self->{ADHDP_map} = $fm eq 'RELAY' ? sub {$_[3]} : $fm;
}
lib/Any/Daemon/HTTP/Proxy.pm view on Meta::CPAN
, $args->{change_response} || ()
);
$self->{ADHDP_prepare} = \@prepare;
$self->{ADHDP_postproc} = \@postproc;
$self;
}
#-----------------
sub userAgent() {shift->{ADHDP_ua}}
sub via() {shift->{ADHDP_via}}
sub forwardMap(){shift->{ADHDP_map}}
sub remoteProxy(@)
{ my $rem = shift->{ADHDP_proxy};
$rem ? $rem->(@_) : undef;
}
#-----------------
my $last_used_proxy = '';
sub _collect($$$$)
{ my ($self, $vhost, $session, $req, $rel_uri) = @_;
my $resp;
my $vhost_name = $vhost ? $vhost->name : '';
my $tohost = $req->header('Host') || $vhost_name;
#XXX MO: need to support https as well
my $uri = URI->new_abs($rel_uri, "http://$tohost");
# Via: RFC2616 section 14.45
lib/Any/Daemon/HTTP/Proxy.pm view on Meta::CPAN
, method => $req->method, uri => "$uri", status => $resp->code;
}
$self->$_($resp, $uri)
for @{$self->{ADHDP_postproc}};
$resp;
}
sub stripHeaders(@)
{ my $self = shift;
my @strip;
foreach my $field (@_ > 1 ? @_ : ref $_[0] eq 'ARRAY' ? @{$_[0]} : shift)
{ push @strip
, !ref $field ? sub {$_[0]->remove_header($field)}
: ref $field eq 'CODE' ? $field
: ref $field eq 'Regex' ? sub {
my @kill = grep $_ =~ $field, $_[0]->header_field_names;
$_[0]->remove_header($_) for @kill;
}
: panic "do not understand $field";
}
@strip or return;
sub { my $header = $_[1]->headers; $_->($header) for @strip };
}
sub addHeaders($@)
{ my $self = shift;
return if @_==1 && ref $_[0] eq 'CODE';
my @pairs = @_ > 1 ? @_ : defined $_[0] ? @{$_[0]} : ();
@pairs or return sub {};
sub { $_[1]->push_header(@pairs) };
}
sub proxify($$)
{ my ($self, $request, $uri) = @_;
$request->uri($uri);
$request->header(Host => $uri->authority);
}
sub forwardRewrite($$$)
{ my ($self, $session, $req, $uri) = @_;
$self->allow($session, $req, $uri) or return;
my $mapper = $self->forwardMap or return;
$mapper->(@_);
}
sub forwardRequest($$$)
{ my ($self, $session, $req, $uri) = @_;
$self->_collect(undef, $session, $req, $uri);
}
#----------------
1;
lib/Any/Daemon/HTTP/Session.pm view on Meta::CPAN
use strict;
use warnings;
use Log::Report 'any-daemon-http';
use Socket qw(inet_aton AF_INET AF_INET6 PF_INET PF_INET6);
sub new(%) {my $class = shift; (bless {}, $class)->init({@_})}
sub init($)
{ my ($self, $args) = @_;
$self->{ADHC_store} = $args->{store} || {};
$self;
}
#-----------------
sub client() {shift->{ADHC_client}}
sub get(@) {my $s = shift->{ADHC_store}; wantarray ? @{$s}{@_} : $s->{$_[0]}}
sub set($$) {$_[0]->{ADHC_store}{$_[1]} = $_[2]}
# should not be used
sub _store() {shift->{ADHC_store}}
1;
lib/Any/Daemon/HTTP/Source.pm view on Meta::CPAN
use warnings;
use strict;
use Log::Report 'any-daemon-http';
use Net::CIDR qw/cidrlookup/;
use List::Util qw/first/;
use HTTP::Status qw/HTTP_FORBIDDEN/;
sub _allow_cleanup($);
sub _allow_match($$$$);
sub new(@)
{ my $class = shift;
my $args = @_==1 ? shift : +{@_};
(bless {}, $class)->init($args);
}
sub init($)
{ my ($self, $args) = @_;
my $path = $self->{ADHS_path} = $args->{path} || '/';
$self->{ADHS_allow} = _allow_cleanup $args->{allow};
$self->{ADHS_deny} = _allow_cleanup $args->{deny};
$self->{ADHS_name} = $args->{name} || $path;
$self;
}
#-----------------
sub path() {shift->{ADHS_path}}
sub name() {shift->{ADHS_name}}
#-----------------
sub allow($$$$)
{ my ($self, $session, $req, $uri) = @_;
if(my $allow = $self->{ADHS_allow})
{ $self->_allow_match($session, $uri, $allow) or return 0;
}
if(my $deny = $self->{ADHS_deny})
{ $self->_allow_match($session, $uri, $deny) and return 0;
}
1;
}
sub _allow_match($$$$)
{ my ($self, $session, $uri, $rules) = @_;
my $peer = $session->get('peer');
first { $_->($peer->{ip}, $peer->{host}, $session, $uri) } @$rules;
}
sub _allow_cleanup($)
{ my $p = shift or return;
my @p;
foreach my $r (ref $p eq 'ARRAY' ? @$p : $p)
{ push @p
, ref $r eq 'CODE' ? $r
: index($r, ':') >= 0 ? sub {cidrlookup $_[0], $r} # IPv6
: $r !~ m/[a-zA-Z]/ ? sub {cidrlookup $_[0], $r} # IPv4
: substr($r,0,1) eq '.' ? sub {$_[1] =~ qr/(^|\.)\Q$r\E$/i} # Domain
: sub {lc($_[1]) eq lc($r)} # hostname
}
@p ? \@p : undef;
}
sub collect($$$$)
{ my ($self, $vhost, $session, $req, $uri) = @_;
$self->allow($session, $req, $uri)
or return HTTP::Response->new(HTTP_FORBIDDEN);
$self->_collect($vhost, $session, $req, $uri);
}
sub _collect($$$) { panic "must be extended" }
#-----------------------
#-----------------------
1;
lib/Any/Daemon/HTTP/UserDirs.pm view on Meta::CPAN
$VERSION = '0.30';
use parent 'Any::Daemon::HTTP::Directory';
use warnings;
use strict;
use Log::Report 'any-daemon-http';
sub init($)
{ my ($self, $args) = @_;
my $subdirs = $args->{user_subdirs} || 'public_html';
my %allow = map +($_ => 1), @{$args->{allow_users} || []};
my %deny = map +($_ => 1), @{$args->{deny_users} || []};
$args->{location} ||= $self->userdirRewrite($subdirs, \%allow, \%deny);
$self->SUPER::init($args);
$self;
}
#-----------------
sub userdirRewrite($$$)
{ my ($self, $udsub, $allow, $deny) = @_;
my %homes; # cache
sub { my $path = shift;
my ($user, $pathinfo) = $path =~ m!^/\~([^/]*)(.*)!;
return if keys %$allow && !$allow->{$user};
return if keys %$deny && $deny->{$user};
return if exists $homes{$user} && !defined $homes{$user};
my $d = $homes{$user} ||= (getpwnam $user)[7];
$d ? "$d/$udsub$pathinfo" : undef;
};
lib/Any/Daemon/HTTP/VirtualHost.pm view on Meta::CPAN
use Any::Daemon::HTTP::Proxy;
use HTTP::Status qw/:constants/;
use List::Util qw/first/;
use File::Spec ();
use POSIX::1003 qw(strftime);
use Scalar::Util qw(blessed);
use Digest::MD5 qw(md5_base64);
sub new(@)
{ my $class = shift;
my $args = @_==1 ? shift : {@_};
(bless {}, $class)->init($args);
}
sub init($)
{ my ($self, $args) = @_;
my $name = $self->{ADHV_name} = $args->{name};
defined $name
or error __x"virtual host {pkg} has no name", pkg => ref $self;
my $aliases = $args->{aliases} || 'AUTO';
$self->{ADHV_aliases}
= ref $aliases eq 'ARRAY' ? $aliases
: $aliases eq 'AUTO' ? [ $self->generateAliases($name) ]
lib/Any/Daemon/HTTP/VirtualHost.pm view on Meta::CPAN
my $dirs = $args->{directories} || $args->{directory} || [];
$self->addDirectory($_) for ref $dirs eq 'ARRAY' ? @$dirs : $dirs;
$self->{ADHV_proxies} = {};
my $proxies = $args->{proxies} || $args->{proxy} || [];
$self->addProxy($_) for ref $proxies eq 'ARRAY' ? @$proxies : $proxies;
$self;
}
sub _user_dirs($)
{ my ($self, $dirs) = @_;
$dirs or return undef;
return Any::Daemon::HTTP::UserDirs->new($dirs)
if ref $dirs eq 'HASH';
return $dirs
if $dirs->isa('Any::Daemon::HTTP::UserDirs');
error __x"vhost {name} user_dirs is not an ::UserDirs object"
, name => $self->name;
}
sub _auto_docs($)
{ my ($self, $docroot) = @_;
$docroot or return;
File::Spec->file_name_is_absolute($docroot)
or error __x"vhost {name} documents directory must be absolute"
, name => $self->name;
-d $docroot
or error __x"vhost {name} documents `{dir}' must point to dir"
, name => $self->name, dir => $docroot;
$docroot =~ s/\\$//; # strip trailing / if present
$self->addDirectory(path => '/', location => $docroot);
}
#---------------------
sub name() {shift->{ADHV_name}}
sub aliases() {@{shift->{ADHV_aliases}}}
sub generateAliases($)
{ my ($thing, $h) = @_;
my @a;
$h =~ m/^(([^.:]+)(?:[^:]*)?)(?:\:([0-9]+))?$/;
push @a, $1 if $3; # name with port
push @a, $2 if $1 ne $2; # hostname vs fqdn
push @a, "$2:$3" if $1 ne $2 && $3; # hostname with port
@a;
}
#---------------------
sub addHandler(@)
{ my $self = shift;
return if @_==1 && !defined $_[0];
my @pairs
= @_ > 1 ? @_
: ref $_[0] eq 'HASH' ? %{$_[0]}
: ( '/' => $_[0]);
my $h = $self->{ADHV_handlers} ||= {};
while(@pairs)
lib/Any/Daemon/HTTP/VirtualHost.pm view on Meta::CPAN
$h->{$k} = $v;
}
$h;
}
*addHandlers = \&addHandler;
sub findHandler(@)
{ my $self = shift;
my @path = @_>1 ? @_ : ref $_[0] ? $_[0]->path_segments : split('/', $_[0]);
my $h = $self->{ADHV_handlers} ||= {};
while(@path)
{ my $handler = $h->{join '/', @path};
return $handler if $handler;
pop @path;
}
if(my $handler = $h->{'/'})
{ return $handler;
}
sub { HTTP::Response->new(HTTP_NOT_FOUND) };
}
sub handleRequest($$$;$)
{ my ($self, $server, $session, $req, $uri) = @_;
$uri ||= $req->uri;
info __x"{host} request {uri}", host => $self->name, uri => $uri->as_string;
my $new_uri = $self->rewrite($uri);
if($new_uri ne $uri)
{ info __x"{vhost} rewrote {uri} into {new}", vhost => $self->name
, uri => $uri->as_string, new => $new_uri->as_string;
$uri = $new_uri;
}
lib/Any/Daemon/HTTP/VirtualHost.pm view on Meta::CPAN
my $has_etag = $req->headers->header('ETag');
return HTTP::Response->new(HTTP_NOT_MODIFIED, 'cached dynamic data')
if $has_etag && $has_etag eq $etag;
$resp->headers->header(ETag => $etag);
$resp;
}
#----------------------
sub rewrite($) { $_[0]->{ADHV_rewrite}->(@_) }
sub _rewrite_call($)
{ my ($self, $rew) = @_;
$rew or return sub { $_[1] };
return $rew if ref $rew eq 'CODE';
if(ref $rew eq 'HASH')
{ my %lookup = %$rew;
return sub {
my $uri = $_[1] or return undef;
exists $lookup{$uri->path} or return $uri;
URI->new_abs($lookup{$uri->path}, $uri)
lib/Any/Daemon/HTTP/VirtualHost.pm view on Meta::CPAN
error __x"rewrite rule method {name} in {vhost} does not exist"
, name => $rew, vhost => $self->name;
}
error __x"unknown rewrite rule type {ref} in {vhost}"
, ref => (ref $rew || $rew), vhost => $self->name;
}
sub redirect($;$)
{ my ($self, $uri, $code) = @_;
HTTP::Response->new($code//HTTP_TEMPORARY_REDIRECT, undef
, [ Location => "$uri" ]
);
}
sub mustRedirect($)
{ my ($self, $uri) = @_;
my $new_uri = $self->{ADHV_redirect}->($self, $uri);
$new_uri && $new_uri ne $uri or return;
info __x"{vhost} redirecting {uri} to {new}"
, vhost => $self->name, uri => $uri->path, new => "$new_uri";
$self->redirect($new_uri);
}
sub _redirect_call($)
{ my ($self, $red) = @_;
$red or return sub { $_[1] };
return $red if ref $red eq 'CODE';
if(ref $red eq 'HASH')
{ my %lookup = %$red;
return sub {
my $uri = $_[1] or return undef;
exists $lookup{$uri->path} or return undef;
URI->new_abs($lookup{$uri->path}, $uri);
lib/Any/Daemon/HTTP/VirtualHost.pm view on Meta::CPAN
error __x"redirect rule method {name} in {vhost} does not exist"
, name => $red, vhost => $self->name;
}
error __x"unknown redirect rule type {ref} in {vhost}"
, ref => (ref $red || $red), vhost => $self->name;
}
sub addSource($)
{ my ($self, $source) = @_;
$source or return;
my $sources = $self->{ADHV_sources};
my $path = $source->path;
if(my $old = exists $sources->{$path})
{ error __x"vhost {name} directory `{path}' defined twice, for `{old}' and `{new}' "
, name => $self->name, path => $path
, old => $old->name, new => $source->name;
}
info __x"add configuration `{name}' to {vhost} for {path}"
, name => $source->name, vhost => $self->name, path => $path;
$sources->{$path} = $source;
}
#------------------
sub filename($)
{ my ($self, $uri) = @_;
my $dir = $self->sourceFor($uri);
$dir ? $dir->filename($uri->path) : undef;
}
sub addDirectory(@)
{ my $self = shift;
my $dir = @_==1 && blessed $_[0] ? shift
: Any::Daemon::HTTP::Directory->new(@_);
$self->addSource($dir);
}
sub sourceFor(@)
{ my $self = shift;
my @path = @_>1 || index($_[0], '/')==-1 ? @_ : split('/', $_[0]);
return $self->{ADHV_udirs}
if substr($path[0], 0, 1) eq '~';
my $sources = $self->{ADHV_sources};
while(@path)
{ my $dir = $sources->{join '/', @path};
return $dir if $dir;
pop @path;
}
# return empty list, not undef, when not found
$sources->{'/'} ? $sources->{'/'} : ();
}
#-----------------------------
sub addProxy(@)
{ my $self = shift;
my $proxy = @_==1 && blessed $_[0] ? shift
: Any::Daemon::HTTP::Proxy->new(@_);
error __x"proxy {name} has a map, so cannot be added to a vhost"
, name => $proxy->name
if $proxy->forwardMap;
info __x"add proxy configuration to {vhost} for {path}"
, vhost => $self->name, path => $proxy->path;
( run in 0.301 second using v1.01-cache-2.11-cpan-65fba6d93b7 )