view release on metacpan or  search on metacpan

lib/Gepok.pm  view on Meta::CPAN

    die "Please specify at least one HTTP/HTTPS/Unix socket port"
        unless @server_socks;

    $self->_server_socks(\@server_socks);
    warn "Will be binding to ".join(", ", @server_sock_infos)."\n";
    $self->before_prefork();

    1;
}

sub before_prefork {}

sub _main_loop {
    my ($self) = @_;
    if ($self->_daemon->{parent_pid} == $$) {
        log_info("Entering main loop");
    } else {
        log_info("Child process started (PID $$)");
    }
    $self->_daemon->update_scoreboard({child_start_time=>time()});

    my $sel = IO::Select->new(@{ $self->_server_socks });

    for (my $i=1; $i<=$self->max_requests_per_child; $i++) {
        $self->_daemon->set_label("listening");
        my @ready = $sel->can_read();
        for my $s (@ready) {
            my $sock = $s->accept();
            # sock can be undef
            next unless $sock;
            $self->{_connect_time} = [gettimeofday];
            $self->_set_label_serving($sock);
            while (1) {
                $self->_daemon->update_scoreboard({
                    req_start_time => time(),
                    num_reqs => $i,
                    state => "R",
                });
                $self->{_start_req_time} = [gettimeofday];
                my $req = $sock->get_request;
                $self->{_finish_req_time} = [gettimeofday];
                last unless $req;
                $self->{_client_proto} =
                    $sock->proto_ge("1.1") ? "HTTP/1.1" : "HTTP/1.0";
                $self->_daemon->update_scoreboard({state => "W"});
                my $res = $self->_handle_psgi($req, $sock);
                $self->access_log($req, $res, $sock);
            }
            $self->_daemon->update_scoreboard({state => "_"});
        }
    }
}

# taken from Starman, with modifications. turn PSGI response into actual HTTP
# response and send it to client.
sub _finalize_response {
    my($self, $env, $res, $sock) = @_;

    if ($env->{'psgix.harakiri.commit'}) {
        $self->{_client_keepalive} = 0;
        $self->{_client_harakiri}  = 1;
    }

    my $server_proto = $env->{SERVER_PROTOCOL};
    my $client_proto = $self->{_client_proto};
    my $status       = $res->[0];
    my $message      = status_message($status);
    $self->{_res_status} = $status;

    # generate HTTP status + response headers

    my(@headers, %headers);
    push @headers, "$server_proto $status $message";
    push @headers, "Server: ".
            $self->product_name."/".$self->product_version;
    while (my ($k, $v) = splice @{$res->[1]}, 0, 2) {
        push @headers, "$k: $v";
        $headers{lc $k} = $v;
    }

    if (!$headers{date}) {
        push @headers, "Date: " . time2str(time());
    }

    my $keepalive;
    if ($env->{HTTP_CONNECTION}) {
        $keepalive = $env->{HTTP_CONNECTION} =~ /alive/i ? 1:0;
    }
    # default is keep-alive for HTTP/1.1, but close for HTTP/1.0
    $keepalive //= ($client_proto eq 'HTTP/1.1' ? 1:0);
    # normally HTTP::Daemon prints this, but we're not sending response using
    # HTTP::Daemon
    push @headers, "Connection: ".($keepalive ? "Keep-Alive" : "Close");

    my $chunked;
    my $cl = $headers{'content-length'};
    if ($client_proto eq 'HTTP/1.1') {
        if ($status =~ /^[123]/ && $status != 304 && (!defined($cl) || $cl)) {
            $chunked = 1;
        }
        if (my $te = $headers{'transfer-encoding'}) {
            $chunked = $te eq 'chunked';
        }
    } else {
        # "A server MUST NOT send transfer-codings to an HTTP/1.0 client."
        $chunked = 0;
    }
    push @headers, "Transfer-Encoding: chunked" if $chunked;
    $self->{_chunked} = $chunked;

    #warn "chunked=$chunked, keep-alive=$keepalive, client_proto=$client_proto";

    if ($client_proto le 'HTTP/1.0' && $keepalive && !defined($cl)) {
        # if HTTP/1.0 client requests keep-alive (like Wget), we need
        # Content-Length so client knows when response ends.

        # produce body first so we can calculate content-length
        $self->_finalize_body($env, $res, $sock, 1);
        push @headers, "Content-Length: ".$self->{_res_content_length};
        syswrite $sock, join($CRLF, @headers, '') . $CRLF; # print header
        syswrite $sock, $_ for @{$self->{_body}}; # print body
    } else {
        # print headers + body normally

        syswrite $sock, join($CRLF, @headers, '') . $CRLF; # print header
        $self->_finalize_body($env, $res, $sock);
    }
}

# either print body to $sock, or store it in $self-> (for HTTP/1.0 Keep-Alive
# clients)
sub _finalize_body {
    my ($self, $env, $res, $sock, $save) = @_;
    my $cl = 0;
    $self->{_body} = [] if $save;
    if (defined $res->[2]) {
        Plack::Util::foreach(
            $res->[2],
            sub {
                my $buffer = $_[0];
                my $len = length $buffer;
                $cl += $len;
                if ($self->{_chunked}) {
                    return unless $len;
                    $buffer = sprintf("%x", $len) . $CRLF . $buffer . $CRLF;
                }
                $self->_write_sock($sock, $save, $buffer);
            });
        $self->_write_sock($sock, $save, "0$CRLF$CRLF") if $self->{_chunked};
    } else {
        return Plack::Util::inline_object(
            write => sub {
                my $buffer = $_[0];
                my $len = length $buffer;
                $cl += $len;
                if ($self->{_chunked}) {
                    return unless $len;
                    $buffer = sprintf("%x", $len) . $CRLF . $buffer . $CRLF;
                }
                $self->_write_sock($sock, $save, $buffer);
            },
            # poll_cb => sub { ... },
            close => sub {
                $self->_write_sock($sock, $save, "0$CRLF$CRLF")
                    if $self->{_chunked};
            }
        );
    }
    $self->{_res_content_length} = $cl;
}

sub _write_sock {
    my ($self, $sock, $save, $buffer) = @_;
    if ($save) {