######################################################################
#
# Perl module: P3P::HTTPCheck
#
######################################################################
#
# $Id: http.pl,v 1.1 2000/10/05 22:49:00 koike Exp $
# Created by Yuichi Koike (koike@w3.org)
#

use strict;

######################################################################
package P3P::HTTPCheck;
######################################################################

sub new {
    my ($class, %args) = @_;
	my $self = bless {}, $class;
	my @errors;
	$self->{errors} = \@errors;
	return $self;
}

sub targetURI {
	my ($self, $arg) = @_;
	if($arg) {
		$self->{target_uri} = $arg;
	} else {
		return $self->{target_uri};
	}
}

sub prf_uri {
	my ($self, $arg) = @_;
	if($arg) {
		$self->{prf_uri} = $arg;
	} else {
		return $self->{prf_uri};
	}
}

sub content {
	my ($self, $arg) = @_;
	if($arg) {
		$self->{content} = $arg;
	} else {
		return $self->{content};
	}
}

sub content_type {
	my ($self, $arg) = @_;
	if($arg) {
		$self->{content_type} = $arg;
	} else {
		return $self->{content_type};
	}
}

sub check {
	my ($self, $step, $pr, $prf_uri) = @_;
	$self->{step} = $step;
	$self->{pr} = $pr;
	$self->{prf_uri} = $prf_uri;
	my $target_uri = $self->{target_uri};

	# Intiail message
	my $head = " (
<a target='hwin' href='header.pl?mode=header&uri=$target_uri'>HTTP headers</a>
)";
	$pr->pri("<hr>\n");
	$pr->step($step, 0,  " HTTP Protocol Validation", $head);

	# GET the uri
	my $xml = new P3P::XML;
	$xml->setURI($target_uri);
	$xml->access;

	# Error message
	if($xml->{response}->code ne 200) {
		$self->addError("err", $xml->{error});
	} else {
		# restore the content
		$self->{content} = $xml->{content};
		$self->{content_type} = $xml->{content_type};
	}

	# Search P3P: header
	my @prfs;		# will contain policyref URI
	my $headstr;	# will contain all P3P: header
	my $zero_prf;
	my $multi_prf;
	my $headcount = 0;
	foreach my $p3p ($xml->{response}->headers->header("P3P")) {
		$headstr = "P3P: ".($headstr ? $headstr."\n" : "").$p3p;
		my $count = 0;
		while($p3p =~ s/policyref=(?:\"|\')(.*?)(?:\"|\')//i) {
			push(@prfs, $1);
			$count++;
		}
		if($count eq 0) {
			$zero_prf = 1;
		} elsif($count > 1) {
			$multi_prf = 1;
		}
		$headcount++;
	}

	if($zero_prf) {
		$self->addError("err", "<tt>P3P:</tt> header MUST include 
one [<tt>policyref=\"URI\"</tt>] directive.");
	}

	if($multi_prf) {
		$self->addError("warn", "Each <tt>P3P:</tt> header can include 
only one [<tt>policyref=\"URI\"</tt>] directive.");
	}

	my $new_prf_uri;
	my $errFlag;
	foreach my $rela_uri (@prfs) {
		my $uri = P3P::Common::absoluteURI($rela_uri, $target_uri);
		if($new_prf_uri && ($uri ne $new_prf_uri)) {
			$errFlag = 1;
		}
		$new_prf_uri = $uri;
	}

	if($errFlag) {
		$self->addError("err", "Multiple P3P headers specify different URIs 
for policy refernece file.");
		$new_prf_uri = "";
	} elsif($headcount > 1) {
		$self->addError("warn", "Multiple P3P headers.");
	}

	# Check consistency with well-known location
	my $notOK;
	if($prf_uri && $new_prf_uri && ($prf_uri ne $new_prf_uri)) {
		$self->addError("err", "HTTP header specifies different URI
than <tt>/w3c/p3p.xml</tt>.");
		$notOK = 1;
	}

	# Header printing
	if($headstr) {
		$self->addError("code", $headstr);
	}

	# Print result
	if($headstr && $new_prf_uri && ! $notOK) {
		$pr->pri("<p class='result'>HTTP headers are 
<font color='blue'>P3P compliant</font>.");
	} elsif($headstr) {
		$pr->pri("<p class='result'>Target URI returns <tt>P3P:</tt> header 
<font color='red'>with errors</font>.</p>\n");
	} else {
		$pr->pri("<p class='result'>HTTP headers have no <tt>P3P:</tt> header.</p>\n");
	}

	$self->{prf_uri} = $new_prf_uri;
	$pr->printError($self->errors);
	$self->clearError;

	return 1;
}

sub addError {
	my ($self, $status, $mes) = @_;
	my $err = new P3P::Error;
	$err->status($status);
	$err->message($mes);
	push(@{$self->errors}, $err);
}

sub clearError {
	my ($self) = @_;
	my @new_errors;
	$self->{errors} = \@new_errors;
}

sub errors {
	my ($self) = @_;
	return $self->{errors};
}

# module return code
1;

__END__
