#!/usr/bin/perl
use strict;
use LWP::UserAgent;
use HTTP::Request::Common;

# Between the line like this (see below)
#      my $AllowedDomains = <<LIST;
#   and the line like this,
#      LIST
#   list the allowed domain names separated with one
#   or more white space characters.
#
# This is to restrict opportunities for cross site
#   scripting. Pages can only be retrieved from the
#   domains listed here.
#
# In order to retrieve pages from both example.com and
#   www.example.com, both domains must be listed.

my $AllowedDomains = <<LIST;
www.cs.vu.nl.com   
www.few.vu.nl.com
LIST

# Notes:

# Check for a URL in the query string, as a value in a
#   GET variable, or as a value in a POST variable. The
#   first to match is used. If none match, exit.

my $url = '';
if($ENV{QUERY_STRING} and $ENV{QUERY_STRING} !~ /=/)
{ $url = $ENV{QUERY_STRING}; }
elsif($ENV{QUERY_STRING} and $ENV{QUERY_STRING} =~ /^url=(.+)$/)
{ $url = $1; }
elsif($ENV{REQUEST_METHOD} eq 'POST')
{
	my $buffer;
	read(STDIN,$buffer,$ENV{CONTENT_LENGTH});
	if($buffer =~ /^url=(.+)$/)
	{ $url = $1; }
}
goto BOTTOM unless $url;


# Verify the domain in the URL is allowed. If unable to
#   verify, exit.

my $checkdomain = lc $url;
$checkdomain =~ s!^http://!!i;
$checkdomain =~ s!/.*$!!;
my $domainokay = '';
$AllowedDomains =~ s/^\s*//s;
$AllowedDomains =~ s/\s*$//s;
for my $domain (split /\s+/,$AllowedDomains)
{
	if($checkdomain eq lc($domain))
	{
		$domainokay = 1;
		last;
	}
}
goto BOTTOM unless $domainokay;


# Retrieve the page and print it to the browser.

my ($content,$success) = ();
my $ua = LWP::UserAgent->new;
$ua->agent($ENV{HTTP_USER_AGENT}) if $ENV{HTTP_USER_AGENT};
my $r = $ua->request(GET $url);
$success = $r->is_success if $r->is_success;
if($success)
{ $content = $r->content; }
else
{ $content = 'Something is awry. Status code: '.$r->code; }
print "Content-type: text/html\n\n$content";

BOTTOM:
# end of script