view release on metacpan or  search on metacpan

lib/App/HTTP_Proxy_IMP/IMP/FakeResponse.pm  view on Meta::CPAN

use strict;
use warnings;
package App::HTTP_Proxy_IMP::IMP::FakeResponse;
use base 'Net::IMP::HTTP::Request';
use fields qw(root file response);
no warnings 'experimental'; # smartmatch

use Net::IMP;
use Net::IMP::Debug;
use Carp;
use Digest::MD5;

sub RTYPES { ( IMP_PASS,IMP_REPLACE,IMP_DENY,IMP_ACCTFIELD ) }

sub new_factory {
    my ($class,%args) = @_;
    my $dir = $args{root} or croak("no root directory given");
    -d $dir && -r _ && -x _ or croak("cannot use base dir $dir: $!");
    my $obj = $class->SUPER::new_factory(%args);
    $obj->{root} = $dir;
    return $obj;
}

sub validate_cfg {
    my ($class,%args) = @_;
    my $dir = delete $args{root};
    delete $args{ignore_parameters};
    my @err = $class->SUPER::validate_cfg(%args);
    if ( ! $dir ) {
	push @err, "no 'root' given";
    } elsif ( ! -d $dir || ! -r _ || ! -x _ ) {
	push @err, "cannot access root dir $dir";
    }
    return @err;
}

sub request_hdr {
    my ($self,$hdr) = @_;

    my ($method,$proto,$host,$path) = $hdr =~m{\A([A-Z]+) +(?:(\w+)://([^/]+))?(\S+)};
    $host = $1 if $hdr =~m{\nHost: *(\S+)}i;
    if ( ! $host ) {
	$self->run_callback([IMP_DENY,0,'cannot determine host']);
	return;
    }
    $proto ||= 'http';
    $host = lc($host);
    my $port =
        $host=~s{^(?:\[(\w._\-:)+\]|(\w._\-))(?::(\d+))?$}{ $1 || $2 }e ?
        $3:80;

    my $dir = $self->{factory_args}{root}."/$host:$port";
    goto IGNORE if ! -d $dir;

    my $uri = "$proto://$host:$port$path";
    my $qstring = $path =~s{\?(.+)}{} ? $1 : undef;
    # collect information to determine filename
    my %file = (
	uri => $uri,
        dir => $dir,
        method => $method,
        md5path => Digest::MD5->new->add($path)->hexdigest,
        md5data => undef,
    );

    my $fname = "$dir/".lc($method)."-".$file{md5path};
    goto TRY_FNAME if $self->{factory_args}{ignore_parameters};

    ( $file{md5data} = Digest::MD5->new )->add("\000$qstring\001")
        if defined $qstring;
    if ( $method ~~ [ 'GET','HEAD' ] ) {
	$fname .= "-".$file{md5data}->hexdigest if $file{md5data};
	goto TRY_FNAME;
    }

    # ignore if there will not be a matching filename, no matter
    # what md5data will be
    goto IGNORE if ! -f $fname and ! glob("$fname-*");

    # don't pass yet, continue in request body
    $file{rqhdr} = $hdr; 
    $self->{file} = \%file;
    return; 

    TRY_FNAME:
    if ( $self->{response} = _extract_response($fname)) {
	$hdr =~s{(\A\w+\s+)}{$1internal://};
	debug("hijack http://$host:$port$path");