#! perl
#
# wrtten by Yuichi Koike ($Id: step1.pl,v 1.1 2000/10/05 21:31:06 koike Exp $)
#
require "mylib.pl";

package P3P::HTTPCheck;

sub new {
	my($class, $fn) = @_;
	bless {pr => 0}, $class;
}

sub uri {
	my ($self) = @_;

	return $self->{pr_uri};
}

sub content {
	my ($self) = @_;
	return $self->{content};
}

sub content_type {
	my ($self) = @_;
	return $self->{content_type};
}

sub check {
	my ($self, $uri, $puri, $pr, $step) = @_;
	$self->{pr} = $pr;
	$self->{url} = $uri;
	$self->{step} = $step;
	$self->{puri} = $puri;
	$self->init;

	# GET method
	my @result = $self->header_check($uri, "GET");
	if($result[0] eq 3) {
		return 0;
	}
	$self->{pr_uri} = $result[1];

	# HEAD method
	$self->check_head($uri);

	# Relative URI
	my $cand = $self->{pr_uri};

	if($cand ne "") {
		unless($cand =~ /^http:/) {
			if($cand =~ /^\//) {
				$uri =~ /(http:\/\/.*?)\//;
				$cand = $1.$cand;
			} else {
				$uri =~ /(.*\/)/;
				$cand = $1.$cand;
			}
		}
	}
	$self->{pr_uri} = $cand;

	return 1;
}

sub init {
	my ($self) = @_;
	my $step = $self->{step};
	my $pr = $self->{pr};

	$pr->pri("<hr>");
	$pr->pri("<p><span class='step'>Step $step: </span>\n");
	$pr->pri("<span class='big'>HTTP Protocol Validation</span> \n");
	$pr->pri("(\n<a target='hwin' href='header.pl?url=");
	$pr->pri($self->{url}."'>HTTP headers</a>\n)</p>\n");
}

sub header_check {
	my ($self, $url, $method) = @_;
	my @retu;
	my $pr = $self->{pr};

	# retrieve
	my %ret = &main'retrieve($url, $method);

	# error handling
	if($ret{"error"}) {
		$pr->err($ret{"error"}." [url=".$url."]");
		$pr->pri("<p class='result'>Fatal error occured. ");
		$pr->pri("Validation process aborted.</p>\n");
		$pr->mes("Try another URL.\n");
		if($method eq "GET") {
			$pr->print_all;
		} else {
			$pr->print_clear;
		}
		push(@retu, 3);
		push(@retu, "fatal");
		return @retu;
	}

	# redirect handling
	if($ret{"redirect"}) {
		$pr->mes("HTTP request was redirected to [<tt>".$ret{"redirect"}."</tt>]");
	}

	# keep contents
	my $res = $ret{"response"};
	if($method eq "GET") {
		$content = $res->content();
		$self->{content} = $content;
		$content_type = $res->headers->content_type;
		$self->{content_type} = $content_type;
	}

	# search for P3P header
	my (%polref, @ns);
	# Search for Opt: header
	my @opt = $res->headers->header("Opt");
	foreach my $opt (@opt) {
		if($opt =~ /\"http\:\/\/www\.w3\.org\/2000\/P3Pv1\"\s*?;\s*?ns\s*?=(\d*)/){
			push(@relhead, "Opt: ".$opt);
		}
		while($opt =~ s/\"http\:\/\/www\.w3\.org\/2000\/P3Pv1\"\s*?;\s*?ns\s*?=(\d*)//) {
			push(@ns, $1);
		}
	}

	# Search for 11-PolicyRef: header
	$res->headers->scan(sub {
		my ($name, $value) = @_;
		my $val = $name.": ".$value;
		if($name =~ /(\d*)-PolicyRef/i) {
			$polref{$1} = $value;
			push(@relhead, $val);
		}
	});

	my $success = 1;

	# If namespace is declared more than once -> error
	if($#ns > 0) {
		$success = 2;
		$pr->err("more than one P3P namespace is declared in the HTTP header\n");
	}

	# If namespace is not declared, not P3P compatible.
	if($#ns < 0) {
		$success = 0;
		if($self->{puri} eq "") {
			$pr->err("No [<tt>Opt: \"http://www.w3.org/2000/P3Pv1\"</tt>] header.\n");
		} else {
			$pr->mes("No [<tt>Opt: \"http://www.w3.org/2000/P3Pv1\"</tt>] header.\n");
		}
	}

	# check if PolilcyRef is correctly declared.
	my $polurl = "";
	if(scalar(keys(%polref)) eq -1) {
		$success = 0;
		$pr->err("No [<tt>XX-PolicyRef:</tt>] header.\n");
	} else {
		my $found = 1;
		foreach my $prefix (@ns) {
			if(! $polref{$prefix}) {
				$found = 0;
			} elsif($polurl eq "") {
				$polurl = $polref{$prefix};
			} elsif($polurl ne $polref{$prefix}) {
				$success = 0;
				$pr->err("Multiple policy reference file candidates.\n");
			}
		}
		if($found eq 0 && $#ns >= 0) {
			# No PolicyRef with correct namespace prefix
			$pr->err("No associated [<tt>XX-PolicyRef:</tt>] header.\n");
			$success = 0;
		}

		# The number of PolicyRef must be 1
		if(scalar(keys(%polref)) > 1 && $success eq 1) {
			$pr->warn("There are extra [<tt>XX-PolicyRef:</tt>] headers.");
		}
	}

	# compare with /p3p.xml
	my $well = $self->{url};
	$well =~ s/(http:\/\/.*?)\//$1\/p3p.xml/;
	if($polurl) {
		if($polurl =~ /^http:/) {
		} elsif($polurl =~ /^\//) {
			$url =~ /(http:\/\/.*?)\//;
			$polurl = $1.$polurl;
		} else {
			$url =~ /(.*\/)/;
			$polurl = $1.$polurl;
		}
	}

	if($self->{puri} && $polurl && $well ne $polurl) {
		my $str = "HTTP header specifies different \n";
		$pr->err($str."policy refernece file URI than <tt>/p3p.xml</tt>.");
	}

	# Print headers, if error
	my $str = "";
	foreach my $opt (@relhead) {
		$str = $str.$opt."\n";
	}
	$pr->code($str);

	if($method eq "GET") {
		$pr->pri("<p class='result'>HTTP headers \n");
		if($success eq 1) {
			$pr->pri("are <font color='blue'>P3P compatible</font>.\n</span><p>\n");
		} elsif($success eq 2) {
			$pr->pri("are <font color='green'>P3P compatible</font>,");
			$pr->pri(" but some errors.</span><p>\n");
		} elsif($self->{puri} eq "") {
			$pr->pri("are <font color='red'>NOT P3P compatible</font>.</span><p>\n");
		} else {
			$pr->pri("have no P3P headers.</span><p>\n");
		}
		$pr->print_all;
	} else {
		$pr->print_clear;
	}

	push(@retu, $success);
	push(@retu, $polurl);

	return @retu;
}

sub check_head {
	my ($self, $uri) = @_;
	my $pr = $self->{pr};
	my $pr_uri = $self->uri;

	if($pr_uri ne "") {
		$#relhead = -1;
		my @result2 = $self->header_check($uri, "HEAD");
		if($result2[0] eq 3) {
			$pr->err("Fatal error occurs, when checking <b>HEAD</b> request.");
		} elsif($result2[0] eq 0) {
			$pr->mes("HTTP <b>HEAD</b> method is \n<font color='red'>NOT supported</font>.");
		} else {
			if($pr_uri eq $result2[1]) {
				$pr->mes("HTTP <b>HEAD</b> method is also \n<font color='blue'>SUPPORTED</font>.");
			} else {
				$pr->err("<b>HEAD</b> method indicates \n<font color='red'>different</font> policy reference URI.\n");
				# Print headers, if error
				my $str = "";
				foreach my $opt (@relhead) {
					$str = $str.$opt."\n";
				}
				chop($str);
				$pr->code($str);
			}
		}
		$pr->print_all;
	}
}

