view release on metacpan or  search on metacpan

lib/DBI/Gofer/Transport/mod_perl.pm  view on Meta::CPAN

use constant MP2 => ( ($ENV{MOD_PERL_API_VERSION}||0) >= 2 or eval "require Apache2::Const");
BEGIN {
  if (MP2) {
    require Apache2::Connection;
    require Apache2::RequestIO;
    require Apache2::RequestRec;
    require Apache2::RequestUtil;
    require Apache2::Response;
    require Apache2::Const;
    Apache2::Const->import(qw(OK DECLINED SERVER_ERROR));
    require APR::Base64;
    *encode_base64 = \&APR::Base64::encode;
    *decode_base64 = \&APR::Base64::decode;
    *escape_html = sub {
        my $s = shift;
        $s =~ s/&/&/g;
        $s =~ s/</&lt;/g;
        $s =~ s/>/&gt;/g;
        return $s;
    }
  }
  else {
    require Apache::Constants;
    Apache::Constants->import(qw(OK DECLINED SERVER_ERROR));
    require Apache::Util;
    Apache::Util->import(qw(escape_html));
    require MIME::Base64;
    MIME::Base64->import(qw(encode_base64 decode_base64));
  }
}

use DBI::Gofer::Serializer::DataDumper;

use base qw(DBI::Gofer::Transport::Base);

our $transport = __PACKAGE__->new();

our %executor_configs = ( default => { } );
our %executor_cache;
our $show_client_hostname_in_status = 1;
our $datadumper_serializer = DBI::Gofer::Serializer::DataDumper->new;

_install_apache_status_menu_items(
    DBI_gofer => [ 'DBI Gofer', \&_apache_status_dbi_gofer ],
);


sub handler : method {
    my $self = shift;
    my $r = shift;
    my $time_received = dbi_time();
    my $headers_in = $r->headers_in;

    my ($frozen_request,  $request,  $request_serializer);
    my ($frozen_response, $response, $response_serializer);
    my $executor;

    my $http_status = SERVER_ERROR;
    my $remote_ip = $headers_in->{Client_ip}    # e.g., cisco load balancer
        || $headers_in->{'X-Forwarded-For'}     # e.g., mod_proxy (XXX may contain more than one ip)
        || $r->connection->remote_ip;

    eval {
        $executor = $self->executor_for_apache_request($r);

        my $request_content_length = $headers_in->{'Content-Length'};
        # XXX get content-type by response_content_type() meth call on serializer?
        # (need to think-through content-type, transfer-encoding, disposition etc etc
        my $response_content_type = 'application/x-perl-gofer-response-binary';
        # XXX should probably contol flow via method: GET vs POST
        my $of = "";
        if (!$request_content_length) { # assume GET request
            my $args = $r->args || '';
            my %args = map { (split('=',$_,2))[0,1] } split /[&;]/, $args, -1;
            my $req = $args{req}
                or die "No req argument or Content-Length ($args)\n";
            $frozen_request = decode_base64($req);

            if ($args{_dd}) { # XXX temp hack
                $response_serializer = $datadumper_serializer;
                $response_content_type = 'text/plain';
                if ($args{_dd} eq 'request') { # XXX even more of a temp hack
                    $request = $transport->thaw_request($frozen_request);
                    $r->pnotes(gofer_request => $request);
                    $frozen_response = $datadumper_serializer->serialize($request);
                    goto send_frozen_response;
                }
            }
        }
        else {
            my $content_type = $headers_in->{'Content-Type'};
            die "Unsupported gofer Content-Type"
                unless $content_type eq 'application/x-perl-gofer-request-binary';
            $r->read($frozen_request, $request_content_length);
            if (length($frozen_request) != $request_content_length) {
                die sprintf "Gofer request length (%d) doesn't match Content-Length header (%d)",
                    length($frozen_request), $request_content_length;
            }
        }

        $request = $transport->thaw_request($frozen_request);
        $r->pnotes(gofer_request => $request);

        $response = $executor->execute_request( $request );
        $r->pnotes(gofer_response => $response);

        $frozen_response = $transport->freeze_response($response, $response_serializer);

    send_frozen_response:
        $r->content_type($response_content_type);
        # setup http headers
        # See http://perl.apache.org/docs/general/correct_headers/correct_headers.html
        # provide Content-Length for KeepAlive so it works if people want it
        $r->headers_out->{'Content-Length'} = do { use bytes; length($frozen_response) };

        $r->print($frozen_response);

        $http_status = OK;
    };
    if ($@) {