view release on metacpan or  search on metacpan

lib/Any/Daemon/HTTP.pm  view on Meta::CPAN

        push @sockets, $socket if $socket;
        push @hosts, @host;
    }

    @sockets or error __x"host or socket required for {pkg}::new()"
      , pkg => ref $self;

    $self->{ADH_sockets} = \@sockets;
    $self->{ADH_hosts}   = \@hosts;

    $self->{ADH_session_class}
      = $args->{session_class} || 'Any::Daemon::HTTP::Session';
    $self->{ADH_vhost_class}
      = $args->{vhost_class}   || 'Any::Daemon::HTTP::VirtualHost';
    $self->{ADH_proxy_class}
      = $args->{proxy_class}   || 'Any::Daemon::HTTP::Proxy';

    $self->{ADH_vhosts}  = {};
    $self->addVirtualHost($_) for _to_list($args->{vhosts}  || $args->{vhost});

    $self->{ADH_proxies} = [];
    $self->addProxy($_)       for _to_list($args->{proxies} || $args->{proxy});

    !$args->{docroot}
        or error __x"docroot parameter has been removed in v0.11";

    $self->{ADH_server}  = $args->{server_id} || basename($0);
    $self->{ADH_headers} = $args->{standard_headers} || [];
    $self->{ADH_error}   = $args->{on_error}  || sub { $_[1] };
    $self->{ADH_show_ps} = exists $args->{show_in_ps} ? $args->{show_in_ps} : 1;

    # "handlers" is probably a common typo
    my $handler = $args->{handlers} || $args->{handler};

    my $host      = shift @hosts;
    $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');

    my $sock_class;
    if($proto eq 'HTTPS')
    {   $sock_class = 'IO::Socket::SSL';
        eval "require IO::Socket::SSL; require HTTP::Daemon::SSL" or panic $@;
    }
    elsif($proto eq 'HTTP')
    {   $sock_class = 'IO::Socket::IP';
    }
    elsif($proto eq 'FCGI')
    {   $sock_class = 'IO::Socket::IP';
        eval "require Any::Daemon::FCGI" or panic $@;
    }
    else
    {   error __x"Unsupported protocol '{proto}'", proto => $proto;
    }

    # Wait max 60 seconds to get the socket
    # You should be able to reduce the time to wait by setting linger
    # on the socket in the process which has opened the socket before.
    my ($socket, $elapse);
    foreach my $retry (1..60)
    {   $elapse = $retry -1;

        $socket = $sock_class->new
          ( LocalHost => $host
          , LocalPort => $port
          , Listen    => SOMAXCONN
          , Reuse     => 1
          , Type      => SOCK_STREAM
          , Proto     => 'tcp'
          );

        last if $socket || $! != EADDRINUSE;

        notice __x"waiting for socket at {address} to become available"
          , address => "$host:$port"
            if $retry==1;

        sleep 1;
    }

    $socket
        or fault __x"cannot create socket at {address}"
             , 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;

lib/Any/Daemon/HTTP.pm  view on Meta::CPAN

         { $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')
    {   $args->{socket} = $client;
        $conn = Any::Daemon::FCGI::ClientConn->new($args);
    }
    else
    {   # Ugly hack, steal HTTP::Daemon's HTTP/1.1 implementation
        $conn = bless $client, $client->isa('IO::Socket::SSL')
          ? 'HTTP::Daemon::ClientConn::SSL'
          : 'HTTP::Daemon::ClientConn';

        ${*$conn}{httpd_daemon} = $self;
    }

    my $ip   = $client->peerhost;
    my $host =
      ( $client->sockdomain == PF_INET
      ? gethostbyaddr inet_aton($ip), AF_INET
      : undef
      ) || $ip;

    my $session = $self->{ADH_session_class}->new;
    $session->set(peer => { ip => $ip, host => $host });
    info __x"new client from {host} on {ip}" , host => $host, ip => $ip;

    my $init_conn = $args->{new_connection};
    $self->$init_conn($session);

    # Change title in ps-table
    my $title = $0 =~ /^(\S+)/ ? basename($1) : $0;
    $self->psTitle("$title http from $host");

    $SIG{ALRM} = sub {
        notice __x"connection from {host} lasted too long, killed after {time%d} seconds"
          , host => $host, time => $deadline - $start;
        exit 0;
    };

    alarm $deadline - time;
    while(my $req  = $conn->get_request)
    {   my $vhostn = $req->header('Host') || 'default';
		my $vhost  = $self->virtualHost($vhostn);

		$self->_clean_uri($req->uri);

        # Fallback to vhost without specific port number
        $vhost ||= $self->virtualHost($1)
            if $vhostn =~ /(.*)\:[0-9]+$/;

        my $resp;
        if($vhost)
        {   $self->{ADH_host_base}
              = (ref($conn) =~ /SSL/ ? 'https' : 'http').'://'.$vhost->name;
            $resp = $vhost->handleRequest($self, $session, $req);
        }
        elsif(my ($proxy, $where) = $self->findProxy($session, $req, $vhostn))
        {   $resp = $proxy->forwardRequest($session, $req, $where);
        }
        elsif(my $default = $self->virtualHost('default'))
        {   $resp = HTTP::Response->new(HTTP_TEMPORARY_REDIRECT);
            $resp->header(Location => 'http://'.$default->name);
        }
        else
        {   $resp = HTTP::Response->new(HTTP_NOT_ACCEPTABLE,
               "virtual host $vhostn is not available");
        }

        unless($resp)