File Coverage

blib/lib/Lemonldap/NG/Handler/Proxy.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

## @file
# Perl based proxy used to replace mod_proxy

## @class
# Perl based proxy used to replace mod_proxy
package Lemonldap::NG::Handler::Proxy;

use strict;

use Lemonldap::NG::Handler::Main qw(:apache :headers :tsv);
use LWP::UserAgent;
use Lemonldap::NG::Handler::Main::Headers;
use Lemonldap::NG::Handler::Main::Logger;

our $VERSION = '1.2.0';

##########################################
# COMPATIBILITY WITH APACHE AND APACHE 2 #
##########################################

BEGIN {
    if ( MP() == 2 ) {
        Apache2::compat->import();
    }
    *handler = ( MP() == 2 ) ? \&handler_mp2 : \&handler_mp1;
}

## @cmethod int handler_mp1()
# Launch run() when used under mod_perl version 1
# @return Apache constant
sub handler_mp1 ($$) { shift->run(@_); }

## @cmethod int handler_mp2()
# Launch run() when used under mod_perl version 2
# @return Apache constant
sub handler_mp2 : method {
    shift->run(@_);
}

*lmLog = *Lemonldap::NG::Handler::Main::lmLog;

########
# MAIN #
########

# Shared variables
our $r;
our $base;
our $headers_set;
our $UA = new LWP::UserAgent;
our $class;

# IMPORTANT: LWP does not have to execute any redirection itself. This has to
# be done by the client itself, else cookies and other information may
# disappear.
$UA->requests_redirectable( [] );

## @cmethod int run(Apache2::RequestRec r)
# Main proxy method.
# Called for Apache response (PerlResponseHandler).
# @return Apache constant
sub run($$) {
    ( $class, $r ) = splice @_;
    my $url = $r->uri;
    $url .= "?" . $r->args if ( $r->args );

    # Uncomment this if you have lost of session problem with SAP.
    # I don't know why cookie value and URL parameter differs but it causes
    # this problem. By removing URL parameters, all works fine. SAP bug ?

    # $url =~ s/sap-wd-cltwndid=[^\&]+//g;
    return DECLINED unless ( $base = $r->dir_config('LmProxyPass') );
    my $request = new HTTP::Request( $r->method, $base . $url );

    # Scan Apache request headers to generate LWP request headers
    $r->headers_in->do(
        sub {
            return 1 if ( $_[1] =~ /^$/ );
            $request->header(@_) unless ( $_[0] =~ /^(Host|Referer)$/i );
            Lemonldap::NG::Handler::Main::Logger->lmLog(
                "$class: header pushed to the server: " . $_[0] . ": " . $_[1],
                'debug'
            );
            1;
        }
    );
    $base =~ s/https?:\/\/([^\/]+).*$/$1/;
    $request->header( Host => $base );

    # copy POST data, if any
    if ( $r->method eq "POST" ) {
        my $len = $r->headers_in->{'Content-Length'};
        my $buf;
        if ($len) {
            $r->read( $buf, $len );
            $request->content($buf);
        }
    }
    $headers_set = 0;

    # For performance, we use a callback. See LWP::UserAgent for more
    my $response = $UA->request( $request, \&cb_content );
    if ( $response->code != 200 ) {
        $class->headers($response) unless ($headers_set);
        $r->print( $response->content );
    }
    return OK;
}

## @fn void cb_content(string chunk)
# Send datas received from remote server to the client.
# @param $chunk part of datas returned by HTTP server
sub cb_content {
    my $chunk = shift;
    unless ($headers_set) {
        $class->headers(shift);
        $headers_set = 1;
    }
    $r->print($chunk);
}

## @cmethod void headers(HTTP::Request response)
# Send headers received from remote server to the client.
# Replace "Location" header.
# @param $response current HTTP response
sub headers {
    $class = shift;
    my $response = shift;
    my $tmp      = $response->header('Content-Type');
    $r->content_type($tmp) if ($tmp);
    $r->status( $response->code );
    $r->status_line( join ' ', $response->code, $response->message );

    # Scan LWP response headers to generate Apache response headers
    my ( $location_old, $location_new ) = split /[;,]+/,
      $r->dir_config('LmLocationToReplace');
    my ( $cookieDomain_old, $cookieDomain_new ) = split /[;,]+/,
      $r->dir_config('LmCookieDomainToReplace');

    $response->scan(
        sub {

            # Replace Location headers
            $_[1] =~ s#$location_old#$location_new#o
              if ( $location_old and $location_new and $_[0] =~ /Location/i );

            # Replace Set-Cookie headers
            $_[1] =~ s#$cookieDomain_old#$cookieDomain_new#o
              if (  $cookieDomain_old
                and $cookieDomain_new
                and $_[0] =~ /Set-Cookie/i );

            Lemonldap::NG::Handler::Main::Headers->lmSetErrHeaderOut( $r, @_ );

            Lemonldap::NG::Handler::Main::Logger->lmLog(
                "$class: header pushed to the client: " . $_[0] . ": " . $_[1],
                'debug'
            );
            1;
        }
    );
    $headers_set = 1;
}

1;

__END__