#! perl
#
# wrtten by Yuichi Koike ($Id: step3.pl,v 1.1 2000/10/05 21:31:06 koike Exp $)
#
# Modules
use vars;
use XML::Parser;
require "mylib.pl";
require "xml.pl";
require "policyref.pl";

package P3P::RefCheck;

my $pr2;
my ($ref_root, $p3p_ns, $rdf_ns, $only_one, $has_prefix);
my ($ref_pos, $ref_pp, $ref_pr, $ref_re, $ref_pe, @ref_elem, @polref, $ref_uri);

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

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

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

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

	$uri =~ s/(http:\/\/.*?)\/.*/$1\/\p3p.xml/;
	return $uri;
}

sub check {
	my ($self, $pr_uri, $target_uri, $pr, $mode, $step, $wellknown) = @_;

	$self->{mode} = $mode;
	$self->{step} = $step;
	$self->{pr_uri} = $pr_uri;
	$self->{target_uri} = $target_uri;
	$self->{pr} = $pr;
	$self->{wellknown} = $wellknown;

	# mode check
	if($mode eq "well") {
		$self->{fname} = "<tt>/p3p.xml</tt>";
	} else {
		$self->{fname} = "Policy Reference File";
	}

	# initialize
	$self->init;

	# exsiting check
	my $res = $self->ref_exist;
	if($res eq 0) {
		if($mode eq "well") {
			return 1;
		} else {
			$pr->pri("<p class='result'>Validation process aborted.</p>\n");
			return 0;
		}
	}

	# syntax check
	my $syn_ret = $self->ref_syntax;
	if($syn_ret eq 0) {
		$pr->pri("<p class='result'>Validation process aborted.</p>\n");
		return 0;
	}

	# semantics check
	$pr->clear_ew;
	my $sem_res = $self->ref_semantics;
	if($sem_res eq 0) {
		$pr->pri("<p class='result'>Validation process aborted.</p>\n");
		return 0;
	} elsif($self->{policy_uri} ne "") {
		$pr->pri("<p class='result'>Validator found P3P Policy is \n");
		$pr->pri("[<tt>".$self->{policy_uri}."</tt>]</p>\n");
		return 1;
	}
}

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

	$pr->pri("<hr>");
	$pr->pri("<p><span class='step'>Step $step: </span>\n");
	$pr->pri("<span class='big'>$fname Validation</span></p>\n");
	$pr->pri("<p><span class='result'>URI: </span>\n");
	$pr->pri("<a target='refwin' href='line.pl?url=$pr_uri'>\n<tt>$pr_uri</tt>\n</a>\n");
}

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

	my $ref_uri = $self->{pr_uri};
	my $method = "GET";
	my %ret = &main'retrieve($ref_uri, $method);

	# first message
	$pr->pri("<p class='result'><font color='#0050B2'>Step $step-1:</font>\n");
	$pr->pri("Access check</p>\n");

	# error handling
	if($ret{"error"}) {
		$pr->err($ret{"error"}." [url=".$ref_uri."]");
		$pr->pri("<p class='result'>&nbsp;&nbsp;$fname \n");
		$pr->pri("<font color='red'>can not</font> be retrieved.</p>\n");
		$pr->print_all;

		return 0;
	}

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

	# content type
	my $ctype = $ret{"response"}->headers->content_type;
	my $str = "The content type of the $fname is \n<b>";
	$str = $str.$ctype."</b>.";
	if($ctype eq "text/html") {
		$str = $str." Following syntax check might be invalid.";
	}
	$pr->mes($str);

	# successful
	$pr->pri("<p class='result2'>$fname \n");
	$pr->pri("<font color='blue'>can be retrieved</font>.</p>\n");

	$pr->print_all;

	$self->{content} = $ret{"response"}->content;
	return 1;
}

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

	# first message
	$pr->pri("<p class='result'><font color='#0050B2'>Step $step-2:</font>\n");
	$pr->pri("Syntax check</p>\n");

	# Check if well-formed
	my $xml = new P3P::XML;
	my $well_res = $xml->well_form($content);
	if($well_res eq 0) {
		$pr->pri("<p class='result2'>$fname is ");
		$pr->pri("<font color='red'>NOT an well-formed XML file</font>.</p>");
		$pr->code($xml->error);
		$pr->print_all;
		return 0;
	}

	# XML Validation check
	$pr->clear_ew;
	my $vres = $self->ref_validate($content);
	if($vres eq 0) {
		return 0;
	}

	# print result
	if($pr->has_err eq 1) {
		$pr->pri("<p class='result2'>$fname syntax has ");
		$pr->pri("<font color='red'>syntax errors</font>.</p>");
	} else {
		$pr->pri("<p class='result2'>$fname syntax is syntactically \n");
		$pr->pri("<font color='blue'>valid</font>.</p>\n");
	}

	$pr->print_all;
	return 1;
}

sub ref_validate {
	my ($self) = @_;
	my $pr = $self->{pr};
	my $content = $self->{content};
	my $fname = $self->{fname};
#	$content =~ s/^\s+(\S)/$1/;

	$ref_root = "POLICY-REFERENCES";
	$p3p_ns = "http://www.w3.org/2000/P3Pv1";
	$rdf_ns = "http://www.w3.org/1999/02/22-rdf-syntax-ns#";
	$ref_re = 0;
	$ref_pe = 0;

	my $parser = new XML::Parser;
	$parser->setHandlers(Start => \&ref_s, End => \&ref_e, Default => \&ref_d);
	$ref_pos = 0;
	$pr2 = $pr;
	@polref = ();
	$ref_uri = $self->{pr_uri};
	$only_one = 0;
	my $pres = eval '$parser->parse($content)';
	if(!$pres) {
		$pr->pri("<p class='result2'>$fname has ");
		$pr->pri("<font color='red'><b>fatal</b> syntax errors</font>.</p>");
		$pr->print_all;
		return 0;
	}
	$self->{polref} = \@polref;
	return 1;
}

sub ref_s {
	my ($expat, $elem, @attr) = @_;
	my $line = $expat->current_line;
	push(@ref_elem, $elem);

	if($ref_pos eq 0) {
		# root element check
		if($elem ne $ref_root) {
			# root element name check
			my $str = "line ".$line.": ";
			$str = $str."Invalid element <tt>&lt;$elem&gt;</tt>.\n";
			$str = $str."Root element must be <tt>&lt;$ref_root&gt;</tt>\n";
			$pr2->err($str);
			die;
		}

		$ref_pos = 1;

		# namespace check
		my $attr_exist = 0;
		for(my $i=0; $i<=$#attr; $i+=2) {
			my $name = $attr[$i];
			my $value = $attr[$i+1];
			if($name =~ /xmlns/) {
				my $prefix = "";
				if($name =~ /xmlns:(.*)/) {
					$prefix = $1.":";
				}
				if($value eq $p3p_ns) {
					$ref_pp = $prefix;
					$attr_exist += 1;
				} elsif($value eq $rdf_ns) {
					$ref_pr = $prefix;
					$attr_exist += 2;
				} else {
					my $str = "line ".$line.": ";
					$str = $str."Invalid namespace declaraion. \n";
					$str = $str."Namespace must be [<tt>$p3p_ns</tt>]";
					$str = $str." or [<tt>$rdf_ns</tt>].\n";
					$pr2->err($str);
				}
			} else {
				my $str = "line ".$line.": ";
				$str = $str."Attribute <tt>$name</tt> is not allowed in the ";
				$str = $str."<tt>&lt;$ref_root&gt;</tt> element.\n";
				$pr2->warn($str);
			}
		}
		if($attr_exist eq 0) {
			my $str = "line ".$line.": ";
			$str = $str."Namespace declarations are missing.\n";
			$pr2->err($str);
			die;
		} elsif($attr_exist eq 1) {
			my $str = "line ".$line.": ";
			$str = $str."Namespace declarations for RDF is missing.\n";
			$pr2->err($str);
			die;
		} elsif($attr_exist eq 2) {
			my $str = "line ".$line.": ";
			$str = $str."Namespace declarations for policy reference files is missing.\n";
			$pr2->err($str);
			die;
		}
	} elsif($ref_pos eq 1) {
		my $expected = $ref_pr."RDF";
		if($elem ne $expected) {
			my $str = "line ".$line.": ";
			$str = $str."Invalid element <tt>&lt;$elem&gt;</tt>. \n";
			$str = $str."Only <tt>&lt;$expected&gt;</tt> is allowed here.\n";
			$pr2->err($str);
			die; # cannot continue
		}

		# attribute check
		if($#attr ne -1) {
			my $str = "line ".$line.": ";
			$str = $str."No attribute is not allowed in the ";
			$str = $str."<tt>&lt;$expected&gt;</tt> element.\n";
			$pr2->warn($str);
		}

		$ref_pos = 2;
		$ref_re = 1;
	} elsif($ref_pos eq 2) {
		my $expected = $ref_pp."POLICY-REF";
		if($elem ne $expected) {
			my $str = "line ".$line.": ";
			$str = $str."Invalid element <tt>&lt;$elem&gt;</tt>. \n";
			$str = $str."Only <tt>&lt;$expected&gt;</tt> is allowed here.\n";
			$pr2->err($str);
			die; # cannot continue
		}
		$ref_pos = 3;
		$ref_pe = 1;
		$has_prefix = 0;

		# attribute check
		my $avalue = "";
		my $exat = $ref_pr."about";
		my $attr_exist = 0;
		for(my $i=0; $i<=$#attr; $i+=2) {
			my $name = $attr[$i];
			my $value = $attr[$i+1];
			if($name eq $exat) {
				$attr_exist = 1;
				$avalue = $value;
			} else {
				my $str = "line ".$line.": ";
				$str = $str."Attribute <tt>$name</tt> is not allowed in the ";
				$pr2->warn($str."<tt>&lt;$expected&gt;</tt> element.\n");
			}
		}
		if($attr_exist eq 0) {
			my $str = "line ".$line.": ";
			$str = $str."Attribute <tt>$exat</tt> is necessary in the ";
			$str = $str.."<tt>&lt;$expected&gt;</tt> element.\n";
			$pr2->err($str);
			die;
		}

		my $pol = new P3P::PolicyRef;
		$pol->base_uri($ref_uri);
		$pol->uri($avalue);
		$pol->line($expat->current_line);
		push(@polref, $pol);
	} elsif($ref_pos >= 3 && $ref_pos <= 5) {
		my $exp1 = $ref_pp."PREFIX";
		my $exp2 = $ref_pp."EXCLUDE";
		my $exp3 = $ref_pp."METHOD";

		if($exp1 eq $elem) {
			$has_prefix = 1;
		}

		if($ref_pos eq 3 || $ref_pos eq 4 || $ref_pos eq 5) {
			if($elem ne $exp1 && $elem ne $exp2 && $elem ne $exp3) {
				my $str = "line ".$line.": ";
				$str = $str."Invalid element <tt>&lt;$elem&gt;</tt>. \n";
				$str = $str."Only <tt>&lt;$exp1&gt;</tt> ";
				$str = $str."or <tt>&lt;$exp2&gt;</tt> ";
				$str = $str."or <tt>&lt;$exp3&gt;</tt> ";
				$str = $str."is allowed here.\n";
				$pr2->err($str);
				die;
			}
		}

		# attribute check
		if($#attr ne -1) {
			my $str = "line ".$line.": ";
			$str = $str."No attribute is not allowed in the ";
			$pr2->warn($str."<tt>&lt;$elem&gt;</tt> element.\n");
		}
		$ref_pos = 6;
	} elsif($ref_pos eq 6) {
		my $str = "line ".$line.": ";
		$str = $str."Invalid element <tt>&lt;$elem&gt;</tt>. \n";
		$str = $str."No element is allowed here.\n";
		$pr2->err($str);
		die;
	}
}

sub ref_e {
	my ($expat, $elem) = @_;
	my $line = $expat->current_line;
	pop (@ref_elem);

	my $exp1 = $ref_pp."PREFIX";
	my $exp2 = $ref_pp."EXCLUDE";
	my $exp3 = $ref_pp."METHOD";

	if($ref_pos eq 1) {
		if($ref_re ne 1) {
			my $str = "line ".$line.": ";
			$str = $str."<tt>&lt;$elem&gt;</tt> is not supposed to end here.\n";
			$pr2->err($str);
			die;
		}
	} elsif($ref_pos eq 2) {
		my $exp = $ref_pr."RDF";
		if($ref_pe ne 1) {
			my $str = "line ".$line.": ";
			$str = $str."<tt>&lt;$elem&gt;</tt> is not supposed to end here.\n";
			$pr2->err($str);
			die;
		} else {
			$ref_pos = 1;
		}
	} elsif($ref_pos eq 6) {
		if($elem eq $exp1) {
			$ref_pos = 3;
		} elsif($elem eq $exp2) {
			$ref_pos = 4;
		} elsif($elem eq $exp3) {
			$ref_pos = 5;
		}
	} else {
		if($has_prefix eq 0) {
			if($only_one eq 1) {
				my $str = "line ".$line.": ";
				$str = $str."Only one <tt>&lt;POLICY-REF&gt;</tt> element without ";
				$str = $str."<tt>&lt;PREFIX&gt;</tt> elements is allowed.";
				$pr2->err($str);
			} else {
				$only_one = 1;
			}
		}

		$ref_pos = 2;
	}

	1;
}

sub ref_d {
	my ($expat, $str2) = @_;

	# Trim
	$str2 =~ s/\s|\n//g;
	if($str2 eq "" || $str2 =~ /<\?.*\?>/ || $str2 =~ /<!--.*?-->/) {
		return 1;
	}

	if($ref_pos ne 6) {
		my $str = "line ".$expat->current_line.": CDATA is not allowd in <tt>&lt;";
		$str = $str.$ref_elem[$#ref_elem];
		$str = $str."&gt;</tt> element $str2\n";
		$pr2->err($str);
		return 1;
	}

	my $exp1 = $ref_pp."PREFIX";
	my $exp2 = $ref_pp."EXCLUDE";
	my $exp3 = $ref_pp."METHOD";
	my $pol = $polref[$#polref];
	my $line = $expat->current_line;
	if($ref_elem[$#ref_elem] eq $exp1) {
		push(@{$pol->prefix}, [$str2, $line]);
	} elsif($ref_elem[$#ref_elem] eq $exp2) {
		push(@{$pol->exclude}, [$str2, $line]);
	} elsif($ref_elem[$#ref_elem] eq $exp3) {
		push(@{$pol->method}, [$str2, $line]);
	}

	1;
}

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

	# first message
	$pr->pri("<p class='result'><font color='#0050B2'>Step $step-3:</font>\n");
	$pr->pri("Consistency check</p>\n");

	# Normalize
	foreach my $pol (@{$self->{polref}}) {
		eval '$pol->normalize';
	}

	# Other site check
	my $target = $self->{target_uri};
	$target =~ s/(http:\/\/.*?)\/.*/$1/;
	foreach my $pol (@{$self->{polref}}) {
		foreach my $rela (@{$pol->prefix}) {
			unless ($$rela[0] =~ /^$target/) {
				my $line = $$rela[1];
				my $str = "line ".$line.": ";
				$str = $str."The URIs must be in the same site of ";
				$str = $str."the target URI.\n";
				$pr->err($str);
			}
		}
	}

	# Prefix-Exclude check
	# Check if in each <POLICY-REF> tag is self-consistent
	foreach my $pol (@{$self->{polref}}) {
		foreach my $rela (@{$pol->exclude}) {
			my $ok = 0;
			foreach my $rela2 (@{$pol->prefix}) {
				if($$rela[0] =~ /^$$rela2[0]/) {
					$ok = 1;
				}
			}
			if($ok eq 0) {
				my $line = $$rela[1];
				my $str = "line ".$line.": ";
				$str = $str."<tt>EXCLUDE</tt> value must be included in \n";
				$str = $str."<tt>PREFIX</tt>.\n";
				$pr->err($str);
			}
		}
	}

	# Check if multiple <POLICY-REF> elements are consistent with each other
	# This algorhythm does not seem to be optimized...
	foreach my $pol1 (@{$self->{polref}}) {
		foreach my $pol2 (@{$self->{polref}}) {
			if($pol1 != $pol2) {
				foreach my $pres1 (@{$pol1->prefix}) {
					my $pre1 = $$pres1[0];
					my $collide = 0;
					foreach my $pres2 (@{$pol2->prefix}) {
						if($pre1 =~ /^$$pres2[0]/) {
							$collide = 1;
						}
						if($collide eq 1)
						{
							foreach my $exs2 (@{$pol2->exclude}) {
								if($pre1 =~ /^$$exs2[0]/) {
									$collide = 0;
								}
							}
						}
						if($collide eq 1) {
							my $line1 = $$pres1[1];
							my $line2 = $$pres2[1];
							my $str = "<tt>&lt;POLICY-REF&gt;</tt> elements overlap.\n ";
							$str = $str."line ".$line1." [<tt>$$pres1[2]</tt>] and ";
							$str = $str."line ".$line2." [<tt>$$pres2[2]</tt>].\n";
							$pr->err($str);
						}
					}
				}
			}
		}
	}

	# Search the policy URI
	my @found_line = ();
	my @ok_uri = ();
	foreach my $pol (@{$self->{polref}}) {
		my $uri = $pol->policy($self->{target_uri}, $self->{wellknown});
		if($uri ne "") {
			push(@found_line, $pol->line);
			push(@ok_uri, $uri);
		}
	}

	$self->{policy_uri} = "";
	if($#found_line eq -1) {
		my $str = "$fname does not specify any P3P Policy for \n";
		$str = $str."[<tt>".$self->{target_uri}."</tt>]\n";
		if($self->{mode} eq "well") {
			$pr->mes($str);
		} else {
			$pr->err($str);
		}
	} elsif($#found_line eq 0) {
		$self->{policy_uri} = $ok_uri[0];
	} else {
		my $str = "$fname specifies more than one P3P Policies for \n";
		$str = $str."[<tt>".$self->{target_uri}."</tt>]\n";
		$pr->err($str);
	}

	if($self->{policy_uri} eq "") {
		if($self->{mode} eq "well" && $#found_line < 1) {
			$pr->pri("<p class='result2'>$fname is ");
			$pr->pri("<font color='blue'>consistent</font>.</p>");
			$pr->print_all;
			return 1;
		} else {
			$pr->pri("<p class='result2'>$fname has ");
			$pr->pri("<font color='red'>fatal</font> consitency errors.</p>");
			$pr->print_all;
			return 0;
		}
	} elsif($pr->has_err eq 1) {
		$pr->pri("<p class='result2'>$fname has ");
		$pr->pri("<font color='green'>consitency errors</font>.</p>");
		$pr->print_all;
		return 1;
	} else {
		$pr->pri("<p class='result2'>$fname is ");
		$pr->pri("<font color='blue'>consistent</font>.</p>");
		$pr->print_all;
		return 1;
	}
}

1;
