Beefy Boxes and Bandwidth Generously Provided by pair Networks
good chemistry is complicated,
and a little bit messy -LW
 
PerlMonks  

http wrapper

by dree (Monsignor)
on Apr 21, 2002 at 21:02 UTC ( #160927=sourcecode: print w/ replies, xml ) Need Help??

Category: CGI Programming
Author/Contact Info dree <dree@perlmongers.it>
Description: This script is a wrapper (or a proxy) for HTTP. Briefly it allows to redirect to the browser the content of a site target, masking the true address of the target.
-------------------------- | site with HTTP wrapper | -------------------------- / \ / \ --------------- ------------------ | site target | | user's browser | --------------- ------------------

As an example, if the site target is www.mysite.suffix and the HTTP wrapper is installed on www.perlmongers.it/cgi-bin/tools/http_wrapper.pl/ (<- notice the final slash) by calling this address, you are browsing the site target. If the site target has links and images indicated with *relative* addresses, the user will not be able to notice that the site target is masked by the wrapper. Of course, ALL will pass for the wrapper, that actually it browses the target page, returning the same page and the objects contained in this, to the user's browser. All that is obviously EXPENSIVE (in computational terms) for the site that executes the wrapper. Always, in presence of relative addresses, it works also with upload, form mail, etc :)))
#!/usr/bin/perl

# http_wrapperl.pl v0.9.0 by dree <dree@perlmongers.it>
#
# Copyleft: Nordest Perl Mongers (http://www.perlmongers.it)
#
# License: GPL (http://www.gnu.org/copyleft/gpl.html)

use strict;
use CGI;
use LWP::UserAgent;
use HTTP::Request::Common;

my $q=new CGI;
my $ua = LWP::UserAgent->new;

###############
# CONFIGURATION
###############

my $target_base_address=q[http://www.mysite.suffix]; # site target

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

my $method;
my $content;
my $submit;
my $content_type;
my $target_remaining_address=$q->path_info();

# method acknowledgment
if ($ENV{REQUEST_METHOD} eq 'POST') {

        $method='POST';

} elsif ($ENV{REQUEST_METHOD} eq 'GET') {

        $method='GET';

} elsif (index($target_remaining_address,'GET',0) > -1) {

        $target_remaining_address=~s#^/GET(.+)#$1#;
    $method='GET';

} elsif (index($target_remaining_address,'POST',0) > -1) {

        $target_remaining_address=~s#^/POST(.+)#$1#;
    $method='POST';

} else {

    $method='GET';
}

# management of images & other (if presents) on a *POST* request
if ($method eq 'POST') {

        my $other_remaining_on_POST=uc substr($target_remaining_addres
+s,-3,3);

        if ($other_remaining_on_POST eq '.JS') {

            $method='GET';

        } else {

            $other_remaining_on_POST=uc substr($target_remaining_addre
+ss,-4,4);

            if (($other_remaining_on_POST eq '.GIF')
                or ($other_remaining_on_POST eq '.JPG')
                or ($other_remaining_on_POST eq '.PNG')
                or ($other_remaining_on_POST eq '.CSS')) {

                $method='GET';

            } else {

                $other_remaining_on_POST=uc substr($target_remaining_a
+ddress,-5,5);

                if ($other_remaining_on_POST eq '.JPEG') {

                    $method='GET';
                }
            }
        }
}

my $target_full_address=$target_base_address.$target_remaining_address
+;

if ($ENV{QUERY_STRING}) {

    $target_full_address.="?$ENV{QUERY_STRING}";
}

if ($method eq 'POST') {

    foreach my $key ($q->param) {

        my $val=$q->param("$key");
                my $name_attach;
                my $tmpfilename;

        if (eval {$tmpfilename = $q->tmpFileName($val);}) {

            ($name_attach=$val)=~s#.+\\(.+)#$1#;

            my $type = $q->uploadInfo($val)->{'Content-Type'};

            if (!$type) {

                $type='application/octet-stream';
            }

            $content.=qq{$key => ["$tmpfilename",'$name_attach',Conten
+t_Type=>'$type'],};
            $method='POST-ATTACH';

        } else {

            $content.=qq{$key => '$val',};
        }
    }
}

if ($method eq 'GET') {

    $submit=qq{GET '$target_full_address'};

} else {

    $submit=qq{POST '$target_full_address'};

    if ($method eq 'POST') {

        $content_type=q{application/x-www-form-urlencoded};

    } elsif ($method eq 'POST-ATTACH') {

        $content_type=q{form-data};
    }

    if ($content) {

        chop($content);

        $submit.=qq{,
            Content_Type => '$content_type',
            Content => [$content]
        };
    }
}

my $ua_out=eval "\$ua->request($submit)";
my $result=${$ua_out}{'_content'};

if (${$ua_out}{'_rc'} eq '302') {

    my $location=${$ua_out}{'_headers'}{'location'};
        # eventually $location=~s#.+/(.+)#$1#;
    $location="http://$ENV{HTTP_HOST}"."$ENV{SCRIPT_NAME}/$location";
    print "Location: $location\n\n";
    exit;
}

no strict 'refs';

if (${$ua_out}{'_headers'}{'content-type'}[0]) {

        $content_type="${$ua_out}{'_headers'}{'content-type'}[0]"

} else {

        $content_type="${$ua_out}{'_headers'}{'content-type'}";
}

print "Content-Type: $content_type\n\n";
print $result;

exit;

Comment on http wrapper
Download Code
Re: http wrapper
by TheHobbit (Pilgrim) on Apr 21, 2002 at 21:21 UTC

    Hi,
    Good work.. However, you should add code to handle authentification requests. It should not be too hard to do and would raly be a good thing©.

    Cheers
    Leo TheHobbit
    -----BEGIN PERL GEEK CODE BLOCK----- Version: 0.01
    P++>++++c--P6-R+++M++O++MA++E+++PU+BD
    C*D >++S++X WP MO PP++n+CO-->+PO-oG
    A+OLC+OLCC+OLJ-OLCO---OLS+OLL++OLA--Ee
    Ev-uL++(+++)w!m!
    ------END PERL GEEK CODE BLOCK------
Re: http wrapper
by yodabjorn (Monk) on May 04, 2002 at 10:16 UTC
    Nice piece of work.
    I would just like to point out that if you are using apache. Mod_Rewrite can do this verry easily. ( mod_rewrite is awsome if you don't know about it, and you run apache you should check it out!)

    As well SQUID is a proxy and can be setup as a reverse proxy easily.

    I know these aren't all ontopic about perl, but I feel both these projects should get mentioned if someone may hapen upon this in a search.

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://160927]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others pondering the Monastery: (7)
As of 2014-12-19 00:57 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    Is guessing a good strategy for surviving in the IT business?





    Results (69 votes), past polls