File Coverage

blib/lib/Test/Apache/RewriteRules.pm

Criterion	Covered	Total	%
statement	44	214	20.5
branch	0	48	0.0
condition	0	35	0.0
subroutine	13	36	36.1
pod	9	22	40.9
total	66	355	18.5

package Test::Apache::RewriteRules;
use 5.008001;
use strict;
use warnings;
use Carp qw(croak);

use JSON::XS qw(decode_json);
use Path::Class qw(dir file);
use File::Temp qw(tempfile);

use LWP::UserAgent;
use HTTP::Request;

use Test::Differences;
use Test::Httpd::Apache2;
use Test::TCP qw(empty_port);

our $VERSION = '1.0.1';

sub new {
    my ($class, %args) = @_;
    bless { backends => [], %args }, $class;
}

sub available {
    my ($class, %apache_options) = @_;
    my $apache = Test::Httpd::Apache2->new(
        %apache_options,
        auto_start => 0,
    );
    eval { $apache->start };
    my $is_available = !$@;
    eval { undef $apache  };
    $is_available;
}

sub add_backend {
    my ($self, %backend) = @_;
    $backend{port}   ||= empty_port();
    $backend{apache} ||= $self->create_backend_apache(%backend);
    push @{$self->{backends}}, \%backend;
}

sub proxy_port {
    my $self = shift;
    $self->{proxy_port} ||= empty_port();
}

sub proxy_host {
    my $self = shift;
    sprintf q, $self->proxy_port;
}

sub proxy_http_url {
    my $self = shift;
    my $path = shift || q;
       $path =~ s[^//[^/]*/][/];

    sprintf q, $self->proxy_host, $path;
}

sub backend_port {
    my ($self, $backend_name) = @_;

    for my $backend (@{$self->{backends}}) {
        return $backend->{port}
            if $backend->{name} eq $backend_name;
    }

    croak qq;
}

sub backend_host {
    my ($self, $backend_name) = @_;
    sprintf q, $self->backend_port($backend_name);
}

sub get_backend_name_by_port {
    my ($self, $port) = @_;

    for my $backend (@{$self->{backends}}) {
        return $backend->{name}
            if ($backend->{port} || 0) == $port
    }
}

sub rewrite_conf {
    my ($self, $rewrite_conf) = @_;
    $self->{rewrite_conf} ||= $rewrite_conf && file($rewrite_conf);
}

*rewrite_conf_f = \&rewrite_conf;

sub copy_config {
    my ($self, $original_conf, $patterns) = @_;
    $patterns ||= [];
    $original_conf = file($original_conf);
    my $config     = eval { $original_conf->slurp };

    croak $@ if $@;

    while (@$patterns) {
        my $pattern = shift @$patterns;
           $pattern = ref $pattern eq 'Regexp' ? $pattern : qr/\Q$pattern\E/;
        my $replace = shift @$patterns;
        my $code    = ref $replace eq 'CODE' ? $replace : sub { $replace };

        $config =~ s/$pattern/$code->()/ge;
    }

    my $copied_conf = $original_conf->basename;
       $copied_conf =~ s/\.[^.]*//g;
       $copied_conf .= 'XXXXX';

    (undef, $copied_conf) = tempfile(
        $copied_conf,
        DIR => $self->server_root,
    );
    $copied_conf = file($copied_conf);

    my $fh = $copied_conf->openw;
    print $fh $config;
    close $fh;

    $copied_conf;
}

*copy_conf_as_f = \©_config;

sub server_root {
    my $self = shift;
    dir($self->apache->server_root);
}

*server_root_d = \&server_root;

sub proxy_document_root_d {
    my $self = shift;
    $self->server_root->absolute->cleanup;
}

sub receiver {
    my $self   = shift;
    return $self->{receiver} if $self->{receiver};

    my $receiver_path_name = 'url.cgi';
    my $receiver = <<"EOS";
#!/usr/bin/env perl
use strict;
use warnings;
use JSON::XS;

print "Content-Type: application/json;\\n\\n";
print encode_json({
    host            => \$ENV{HTTP_HOST},
    path            => \$ENV{REQUEST_URI},
    path_translated => \$ENV{PATH_TRANSLATED} . (\$ENV{REQUEST_URI} =~ /\\?/ ? "?\$ENV{QUERY_STRING}" : '')
});
EOS

    my $receiver_file = sprintf '%s/%s', $self->server_root, $receiver_path_name;
    open my $fh, "> $receiver_file" or die $!;
    print $fh $receiver;
    close $fh;
    chmod 0755, $receiver_file
        or die "Couldn't chmod receiver file: $receiver_file";

    $self->{receiver} = file($receiver_file);
}

sub custom_conf {
    my $self = shift;

    croak "rewrite conf is required"
        if !$self->rewrite_conf;

    my $custom_conf  = '';
    for my $backend (@{$self->{backends}}) {
        $custom_conf .= sprintf "SetEnvIf Request_URI .* %s=localhost:%s\n",
            $backend->{name}, $backend->{port};
    }

    $custom_conf .= <<"EOS";
ServerName   proxy.test:@{[$self->proxy_port]}
DocumentRoot @{[$self->server_root]}

RewriteRule ^/url\\.cgi/ - [L]

Include "@{[$self->rewrite_conf]}"

Action default-proxy-handler /@{[$self->receiver->basename]} virtual
SetHandler default-proxy-handler

receiver->basename]}>
  SetHandler cgi-script

EOS
}

my @required_modules = qw(
    log_config
    setenvif
    alias
    rewrite
    authn_file
    authz_host
    auth_basic
    mime
    proxy
    proxy_http
    cgi
    actions
);

sub apache {
    my $self = shift;
    return $self->{apache} if $self->{apache};

    my $apache_options = $self->{apache_options} || {};
    $self->{apache} = Test::Httpd::Apache2->new(
        auto_start       => 0,
        listen           => $self->proxy_port,
        required_modules => \@required_modules,
        %$apache_options,
    );
    $self->{apache}->server_root($self->{apache}->tmpdir);
    $self->{apache}
}

sub start_apache {
    my $self = shift;
       $self->apache->custom_conf($self->custom_conf);
       $self->apache->start;

    for my $backend (@{$self->{backends}}) {
        $backend->{apache}->start;
    }
}

sub stop_apache {
    my $self = shift;
       $self->apache->stop if $self->apache->pid;

    for my $backend (@{$self->{backends}}) {
        $backend->{apache}->stop if $backend->{apache}->pid;
    }
}

sub create_backend_apache {
    my ($self, %backend) = @_;
    my $apache_options = $self->{apache_options} || {};
    my $proxy_apache   = $self->apache;
    my $backend_apache = Test::Httpd::Apache2->new(
        auto_start       => 0,
        listen           => $backend{port},
        required_modules => \@required_modules,
        %$apache_options,
    );
    $backend_apache->server_root($proxy_apache->server_root);
    $backend_apache->custom_conf(<<"EOS");
ServerName   @{[$backend{name}]}.test:@{[$backend{port}]}
DocumentRoot @{[$backend_apache->server_root]}

AddHandler cgi-script .cgi
server_root]}>
  Options +ExecCGI


RewriteEngine on
RewriteRule /(.*) /@{[$self->receiver->basename]}/\$1 [L]
EOS
    $backend_apache;
}

sub get_rewrite_result {
    my ($self, %args) = @_;

    my $url    = $self->proxy_http_url($args{orig_path});
    my $method = $Test::Apache::RewriteRules::ClientEnvs::RequestMethod || 'GET';

    my $req = HTTP::Request->new($method => $url);
    my $ua  = LWP::UserAgent->new(max_redirect => 0, agent => '');

    my $UA = $Test::Apache::RewriteRules::ClientEnvs::UserAgent;
    if (defined $UA) {
        $UA =~ s/%%SBSerialNumber%%//g;
        $req->header('User-Agent' => $UA);
    }

    if ($args{orig_path} =~ m[^//([^/]*)/]) {
        $req->header(Host => $1);
    }

    my $cookies = $Test::Apache::RewriteRules::ClientEnvs::Cookies || [];
    if (@$cookies) {
        $cookies = [@$cookies];
        my @c;
        while (@$cookies) {
            my $n = shift @$cookies;
            my $v = shift @$cookies;
            push @c, $n . '=' . $v;
        }
        $req->header(Cookie => join '; ', @c);
    }

    my $header = $Test::Apache::RewriteRules::ClientEnvs::HttpHeader || [];
    if (@$header) {
        $header = [@$header];
        my @c;
        while (@$header) {
            my $n = shift @$header;
            my $v = shift @$header;
            $req->header($n => $v);
        }
    }

    my $res = $ua->request($req);
    die $res->status_line if $res->is_error;

    my $code = $res->code;
    my $result;

    if ($code >= 300) {
        $result = {
            code => $code,
        };
        $result->{location} = $res->header('Location') if $res->header('Location');
    }
    else {
        $result = eval { decode_json($res->content) };
        die $@ if $@;
        $result->{code} = $code;
        $result->{host} =~ s!
            ^(localhost:(\d+))!
            qq[$1 (@{[($self->get_backend_name_by_port($2) || '')]})]
        !xe;

        my $path_translated = delete $result->{path_translated};
        if ($args{use_path_translated}) {
            $result->{path} = $path_translated;
        }
    }

    $result;
}

sub is_host_path {
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my ($self, $orig_path, $backend_name, $path, $name) = @_;
    $backend_name = defined $backend_name ? $backend_name : '';

    my $use_path_translated = !$backend_name;
    my $result = $self->get_rewrite_result(
        orig_path           => $orig_path,
        use_path_translated => $use_path_translated,
    );

    my $host = $backend_name
        ? $self->backend_host($backend_name)
        : $self->proxy_host;
    $host .= " ($backend_name)";

    my $expected = {
        code => 200,
        host => $host,
        path => $path,
    };

    eq_or_diff $result, $expected, $name;
}

sub is_redirect {
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    my ($self, $orig_path, $redirect_url, $name, %args) = @_;
    my $result = $self->get_rewrite_result(orig_path => $orig_path);
    my $code = $args{code} || 302;

    my $expected = {
        code => $code,
    };
    $expected->{location} = $redirect_url if $redirect_url;

    eq_or_diff $result, $expected, $name;
}

sub DESTROY {
    my $self = shift;
       $self->stop_apache;
}

1;

__END__