#!/usr/bin/perl 
# -*- Mode:perl;coding:utf-8-unix-*-

#    Generate XML Signatures for HTML documents on the Web
#    ... using the h6n profile.

#    Copyright © 2007 World Wide Web Consortium,
#    (Massachusetts Institute of Technology, European Research
#    Consortium for Informatics and Mathematics, Keio
#    University). All Rights Reserved. 

#    This work is distributed under the W3C® Software License
#    [1] in the hope that it will be useful, but WITHOUT ANY
#    WARRANTY; without even the implied warranty of
#    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  
#    [1] http://www.w3.org/Consortium/Legal/2002/copyright-software-20021231
  
#    Thomas Roessler <tlr@w3.org>
#    $Id: h6n.pl,v 1.5 2007-12-06 16:55:24 roessler Exp $

use LWP::UserAgent;
use Digest::SHA1 qw(sha1 sha1_base64 sha1_hex);
use XML::LibXML;
use Crypt::OpenSSL::RSA;
use Crypt::OpenSSL::X509;
use Crypt::OpenSSL::Random;
use MIME::Base64;
use HTML::Parser;
use URI;

local $URI::ABS_REMOTE_LEADING_DOTS = 1;

my $DS = 'http://www.w3.org/2000/09/xmldsig#';
my $c14n = 'http://www.w3.org/TR/2001/REC-xml-c14n-20010315';
# my $c14n = 'http://www.w3.org/2001/10/xml-exc-c14n#';
my $hash = 'http://www.w3.org/2000/09/xmldsig#sha1';
my $rsasha1 = 'http://www.w3.org/2000/09/xmldsig#rsa-sha1';
my $TypeManifest = 'http://www.w3.org/2000/09/xmldsig#Manifest';

Crypt::OpenSSL::Random::random_status() or
  die "Unable to sufficiently seed the random number generator.";

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

my $privkey = undef;
my $cert    = undef;
my $the_uri = undef;
my $full_mode = 0;

my $mode = 'verify';

my $arg;

my %Rep;
# my %Manif;
my $signatureURIs = undef;
my @addtl = ();

while ($arg = shift) {
    if ($arg eq '-mode') {
	$mode = shift;
	if (!($mode eq 'verify') and !($mode eq 'sign')) {
	    die "Unknown mode: $mode";
	}
    } elsif ($arg eq '-verify') {
	$mode = "verify";
    } elsif ($arg eq '-sign') {
	$mode = "sign";
    } elsif ($arg eq '-uri') {
	$the_uri = shift;
    } elsif ($arg eq '-rep') {
	my $res = shift;
	my $rep = shift;
	$Rep{$res} = () unless $Rep{$res};
	push @{$Rep{$res}}, $rep;
    }  elsif ($arg eq '-cert') {
	$cert = &get ($ua, shift);
#    } elsif ($arg eq '-manif') {
	# my $res = shift;
	# $Manif{$res} = 1;
    } elsif ($mode eq 'sign') {
	if ($arg eq '-priv') {
	    $privkey = &get ($ua, shift);
	} elsif ($arg eq '-full') {
	    $full_mode = 1;
	} elsif ($arg eq '-simple') {
	    $full_mode = 0;
	} elsif ($arg eq '-add') {
	    my $u = shift;
	    push @addtl, URI->new_abs ($u, $u); # hack
	} else { 
	    die "Unknown argument $arg";
	}
    } elsif ($mode eq 'verify') {
	if ($arg eq '-full') {
	    my $u = shift;
	    $signatureURIs = {};
	    $signatureURIs->{$u} = 'dsig-full';
	} elsif ($arg eq '-simple') {
	    my $u = shift;
	    $signatureURIs = {};
	    $signatureURIs->{$u} = 'dsig-simple';
	} else {
	    die "Unknown argument $arg";
	}
    } else {
	die "Unknown argument $arg";
    }
}

if ($mode eq 'sign') {
    
# print STDERR "Parsing private key: ", "\n", $privkey;
    my $rsa = Crypt::OpenSSL::RSA->new_private_key ($privkey) || die "Bad private key.";
    $rsa->use_pkcs1_padding;
    $rsa->use_sha1_hash;
    
    die "Not a private key." unless $rsa->is_private;
    die "Bad key." unless $rsa->check_key;
    
    print STDERR "\n";
    
#  print STDERR "Parsing certificate: ", "\n", $cert;
    my $x509 = Crypt::OpenSSL::X509->new_from_string ($cert)  || die "Bad certificate.";
    my $rsa_verifier = Crypt::OpenSSL::RSA->new_public_key ($x509->pubkey);
    
    print STDERR "Constructing signature...", "\n";
    
    my $dom = XML::LibXML::Document->new ("1.0", "utf-8");
    
    $dom->setDocumentElement($dom->createElement ('Signature'));
    my $dsSignature = $dom->getDocumentElement;
    $dsSignature->setNamespace ("$DS", "ds");
    my $dsSignedInfo = $dsSignature->addChild (
	$dom->createElement ('ds:SignedInfo'));
    my $dsSignatureValue = $dsSignature->addChild (
	$dom->createElement ('ds:SignatureValue'));
    my $dsKeyInfo = $dsSignature->addChild (
	$dom->createElement ('ds:KeyInfo'));
    
# Construct signedInfo
    
    my $dsCanon = $dsSignedInfo->addChild ($dom->createElement ('ds:CanonicalizationMethod'));
    $dsCanon->setAttribute ('Algorithm', $c14n);
    
    my $dsSignatureMethod = $dsSignedInfo->addChild ($dom->createElement ('ds:SignatureMethod'));
    $dsSignatureMethod->setAttribute ('Algorithm', $rsasha1);
    
# Here's the meat...
    print STDERR "Fetching: $the_uri", "\n";
    
    my $main_doc = &get ($ua, $the_uri);
    my $the_digest = &myBase64 (sha1 ($main_doc));
    
#    print STDERR "  Hash:           \t",  $the_digest, "\n";
    
    $dsSignedInfo->addChild (&constructReference ($dom, $the_digest, $dsSignedInfo->lookupNamespacePrefix ($DS),
	URI => $the_uri, DigestMethod => $hash));
    
    if ($full_mode) {
	my @dependent = &get_dependent_resources ($the_uri, $main_doc);
	push @dependent, @addtl;
	for my $uri (@dependent) {
	    if ($#{$Rep{$uri->as_string}} >= 1) {      ### or $Manif{$uri->as_string}) {
		my @l = ($uri->as_string);
		
		if ($#{$Rep{$uri->as_string}} >= 1) {
		    @l = @{$Rep{$uri->as_string}};
		}
		
		
		print STDERR "Multiple representations for: $uri\n";
		
		my $dsObject = $dsSignature->addChild ($dom->createElement ('ds:Object'));
		my $dsManifest = $dsObject->addChild ($dom->createElement ('ds:Manifest'));
		
		my $id = &generate_id;
		
		$dsManifest->setAttribute ('Id', $id);
		
		for my $uri2 (@l) {
		    print STDERR "Fetching: $uri2", "\n";
		    my $digest = &myBase64 (sha1 (&get ($ua, $uri2)));
#		    print STDERR "  Hash:           \t",  $digest, "\n";
		    $dsManifest->addChild (&constructReference ($dom, $digest, $dsManifest->lookupNamespacePrefix ($DS),
			URI => $uri->as_string, DigestMethod => $hash));
		}
		
		my $digest2 = &myBase64 (sha1 ($dsManifest->toStringC14N));
		$dsSignedInfo->addChild (&constructReference ($dom, $digest2, $dsSignedInfo->lookupNamespacePrefix ($DS),
		    URI => '#' . $id, DigestMethod => $hash, Type => $TypeManifest, Transforms => $c14n));
		
	    } else {
		print STDERR "Fetching: $uri", "\n";
		my $digest = &myBase64 (sha1 (&get ($ua, $uri)));
#		print STDERR "  Hash:           \t",  $digest, "\n";
		$dsSignedInfo->addChild (&constructReference ($dom, $digest, $dsSignedInfo->lookupNamespacePrefix ($DS),
		    URI => $uri->as_string, DigestMethod => $hash));
	    }
	}
    }
    
# Build signature
    
    my $signature = $rsa->sign ($dsSignedInfo->toStringC14N);
    die "Can't verify my own signature" unless $rsa_verifier->verify ($dsSignedInfo->toStringC14N, $signature);
    
    $dsSignatureValue->appendTextNode (myBase64 ($signature));
    
    my $dsX509Data = $dsKeyInfo->addChild (
	$dom->createElement ('ds:X509Data'));
    my $dsX509Certificate = $dsX509Data->addChild (
	$dom->createElement ('ds:X509Certificate'));

    $dsX509Certificate->appendTextNode (&stripws (&strip_armor ($cert)));
    
# my $dsKeyValue = $dsKeyInfo->addChild ($dom->createElement ('ds:KeyValue'));
# my $dsRSAKeyValue = $dsKeyValue->addChild ($dom->createElement('ds:RSAKeyValue'));
# $dsRSAKeyValue->appendTextChild ('ds:Modulus', &myBase64 ($rsa_n->to_bin));
# $dsRSAKeyValue->appendTextChild ('ds:Exponent', &myBase64 ($rsa_e->to_bin));
    
    print $dom->toStringC14N, "\n";
} else {
    
    # And the verifier...
    
    print STDERR "Fetching: $the_uri", "\n";
    
    my $parser = XML::LibXML->new();
    my $main_doc = &get ($ua, $the_uri);
    my %HashCache = [];
    
    my $notsignedatall = 1;
    
    $HashCache{$the_uri} = sha1 ($main_doc);
    
    # XXX -- we're calling two separate HTML parser instances.  ick!
    $signatureURIs = &get_signature_urls ($the_uri, $main_doc) unless $signatureURIs;
    my @dependent = &get_dependent_resources ($the_uri, $main_doc);
    
    for my $u (keys %{$signatureURIs}) {
	$notsignedatall = 0;

	#####
	##### First stage, parse the signature
	##### 
	
	print STDERR "\n";
	print STDERR "STARTING validation of ", $u,  "\n";
	
	print STDERR "Fetching: ",  $u, "\n";
	
	my $dom = $parser->parse_string (&get ($ua, $u));
	my $dsSignature  = $dom->getDocumentElement();
	
	die "Document element isn't ds:Signature" unless
	  ($dsSignature->localname eq "Signature") and ($dsSignature->namespaceURI eq $DS);
	
	
	#####  Process SignedInfo #####
	
	my %ReferenceHash;
	my %ManifestNode;
	my %ManifestHash;
	my $next = undef;
	my $tmp  = undef;
	my $tmpv = undef;
	my $cur  = undef;

	my $dsSignedInfo = $dsSignature->firstChild;
	
	die "Can't find ds:SignedInfo" unless
	  ($dsSignedInfo->localname eq "SignedInfo") and ($dsSignedInfo->namespaceURI eq $DS);
	
	
	$cur = $dsSignedInfo->firstChild;
	die "ds:CanonicalizationMethod not found" unless
	  ($cur->localname eq "CanonicalizationMethod") and ($cur->namespaceURI eq $DS);
	
	$tmpv = $cur->getAttribute ("Algorithm");
	die "Canonicalization method '$tmpv' not supported." unless
	  $tmpv eq $c14n;
	
	$cur = $cur->nextSibling;
	die "ds:SignatureMethod not found" unless
	  ($cur->localname eq "SignatureMethod") and ($cur->namespaceURI eq $DS);
	
	$tmpv = $cur->getAttribute ("Algorithm");
	die "Signature Method $tmpv not supported." unless
	  $tmpv eq $rsasha1;

	$next = $cur->nextSibling;
	
	die "No References found." unless $next->localname eq 'Reference';

	while ($next && $next->localname eq 'Reference') {
	    $cur = $next;
	    
	    die "Bad Reference element" unless
	      ($cur->localname eq "Reference") and ($cur->namespaceURI eq $DS);
	    
	    my $refuri  = $cur->getAttribute ("URI");
	    my $reftype = $cur->getAttribute ("Type");

	    if ($refuri eq '') {
		die "Don't know how to deal with references to self.";
	    }
	    
	    if ($refuri =~ /^#/) {
		# print STDERR "  refuri    \t", $refuri;
		# print STDERR "  reftype   \t", $reftype;
		die "Bad same-document URI reference." unless
		  $reftype eq $TypeManifest;
		$tmp = $cur->firstChild;
		
		die "ds:Transforms no found" unless 
		  ($tmp->localname eq "Transforms") and ($tmp->namespaceURI eq $DS);
		
		my $tmp2 = $tmp->firstChild;
		die "ds:Transform not found" unless
		  ($tmp2->localname eq "Transform") and ($tmp2->namespaceURI eq $DS);
		
		die "Only one transform permitted" unless $tmp2->isSameNode ($tmp->lastChild);
		die "Only $c14n is permitted" unless $tmp2->getAttribute ("Algorithm") eq $c14n;
		
		$tmp = $tmp->nextSibling;
		
	    } else {
		die "Gratuitous Type attribute on external reference." if
		  $reftype;
		# Resolve relative URI references properly, and use these
		$refuri = URI->new_abs ($refuri, $u)->as_string;
		$tmp = $cur->firstChild;
	    }
	    
	    
	    die "ds:DigestMethod not found, got {" . $tmp->namespaceURI . "}" . $tmp->localname . "\n" unless
	      ($tmp->localname eq "DigestMethod") and ($tmp->namespaceURI eq $DS);
	
	    $tmpv = $tmp->getAttribute ("Algorithm");
	    die "Digest method $tmpv not supported." unless
	      $tmpv eq $hash;
	    
	    $tmp = $tmp->nextSibling;
	    
	    die "ds:DigestValue not found" unless
	      ($tmp->localname eq "DigestValue") and ($cur->namespaceURI eq $DS);
	    
	    $tmpv = &stripws ($tmp->textContent);
	    
	    $ReferenceHash{$refuri} = decode_base64 ($tmpv);

	    die "Spurious content in Reference" if
	      $tmp->nextSibling;
	    
	    $next = $cur->nextSibling;
	}
	
	die "Spurious content in ds:SignedInfo" if $next;
	
	##### Extract value from SignatureValue #####
	
	my $dsSignatureValue = $dsSignedInfo->nextSibling;
	my $the_signature = undef;
	  
	die "Can't find ds:SignatureValue" unless
	  ($dsSignatureValue->localname eq "SignatureValue") and ($dsSignatureValue->namespaceURI eq $DS);
	
	$the_signature = decode_base64 ($dsSignatureValue->textContent);

	##### Now, KeyInfo #####
	
	my $dsKeyInfo = $dsSignatureValue->nextSibling;
	die "Can't find ds:KeyInfo" unless
	  ($dsKeyInfo->localname eq "KeyInfo") and ($dsKeyInfo->namespaceURI eq $DS);
	
	my $dsX509Data = $dsKeyInfo->firstChild;
	die "Can't find ds:X509Data" unless
	  ($dsX509Data->localname eq "X509Data") and ($dsX509Data->namespaceURI eq $DS);
	
	die "Spurious content in X509Data: " . $dsX509Data->nextSibling->localname unless
	  $dsX509Data->isSameNode ($dsKeyInfo->lastChild);
	
	my $dsX509Certificate = $dsX509Data->firstChild;
	die "Can't find ds:X509Certificate" unless
	  ($dsX509Certificate->localname eq "X509Certificate") and ($dsX509Certificate->namespaceURI eq $DS);
	  
	die "I only support one certificate currently, sorry." unless
	  $dsX509Certificate->isSameNode ($dsX509Data->lastChild);
	
	$cert = &cleanup_cert ($dsX509Certificate->textContent) unless defined($cert);
	
	##### Finally, collect the Manifests, if any #####
	
	$next = $dsKeyInfo->nextSibling;
	while ($next and $next->localname eq 'Object') {
	    $cur = $next;
	    
	    die "Bad ds:Object" unless
	      ($cur->localname eq 'Object') and ($cur->namespaceURI eq $DS);
	    	    
	    my $dsManifest = $cur->firstChild;
	    
	    die "Can't find ds:Manifest" unless
	      ($dsManifest->localname eq 'Manifest') and ($dsManifest->namespaceURI eq $DS);
	    
	    die "Only one manifest per object, please" unless
	      $dsManifest->isSameNode ($cur->lastChild);

	    my $manifestId = $dsManifest->getAttribute ("Id");
	    die "All Manifests MUST have an Id attribute" unless
	      $manifestId;
	    
	    $ManifestNode{'#' . $manifestId} = $dsManifest; # hack; will need for core processing
	    
	    my $resource = undef;
	    my $ref = undef;
	    
	    $next = $dsManifest->firstChild;
	    while ($next and ($next->localname eq 'Reference')) {
		$ref = $next;
		
		die "Bad ds:Reference" unless
		  ($ref->localname eq 'Reference') and ($ref->namespaceURI eq $DS);
		
		if (!defined ($resource)) {
		    $resource = $ref->getAttribute('URI');
		    $ManifestHash{$resource} = ();
		} else {
		    die "Manifest is inconsistent." unless $resource eq $ref->getAttribute('URI');
		}
		
		die "No Type on a Reference within a Manifest, please." if $ref->getAttribute('Type');

		$tmp = $ref->firstChild;
		
		die "ds:DigestMethod not found" unless
		  ($tmp->localname eq "DigestMethod") and ($tmp->namespaceURI eq $DS);
		
		$tmpv = $tmp->getAttribute ("Algorithm");
		die "Digest method $tmpv not supported." unless
		  $tmpv eq $hash;
		
		$tmp = $tmp->nextSibling;
		die "ds:DigestValue not found" unless
		  ($tmp->localname eq "DigestValue") and ($tmp->namespaceURI eq $DS);
		
		$tmpv = decode_base64 (&stripws ($tmp->textContent));
		
		push @{$ManifestHash{$resource}}, $tmpv;
		
		die "Spurious content in Reference" if
		  $tmp->nextSibling;
		
		$next = $ref->nextSibling;
	    }
	    
	    die "Spurious data in ds:Manifest: " . $next->localname if $next;
	    
	    $next = $cur->nextSibling;
	}
	
	die "Spurious data in ds:Signature." if $next;

	#####
	##### Stage 2: Core validation
	#####
	
	print STDERR ">>>>> CORE VALIDATION STARTS HERE", "\n";
	
	print STDERR "Checking cryptographic signature", "\n";

#	print STDERR $cert, "\n";
	
	my $x509 = Crypt::OpenSSL::X509->new_from_string ($cert);
	my $rsa_verifier = Crypt::OpenSSL::RSA->new_public_key ($x509->pubkey);
	
	if ($rsa_verifier->verify ($dsSignedInfo->toStringC14N, $the_signature)) {
	    print STDERR "  Signature passed.", "\n";
	} else {
	    print "RSA signature validation failed.", "\n";
	    die "BAD SIGNATURE"
	}

	print STDERR "Checking same-document references (Manifests)", "\n";

	for my $uriref (keys %ReferenceHash) {
	    if ($uriref =~ /^#/) {
		die "Bad same-document URI reference $uriref" unless $ManifestNode{$uriref};
		my $real_hash = sha1 ($ManifestNode{$uriref}->toStringC14N);
		if (!($real_hash eq $ReferenceHash{$uriref})) {
		    print "Reference validation failed for $uriref.", "\n";
		    print "  expected hash: \t", &myBase64 ($ReferenceHash{$uriref}), "\n";
		    print "  got hash:      \t", &myBase64 ($real_hash), "\n";
		    die "BAD SIGNATURE"
		} else {
		    print STDERR "  pass:         \t", $uriref, "\n";
		}
	    }
	}

	print STDERR "Checking remote references", "\n";
	
	my $countremote = 0;
	
	for my $uriref (keys %ReferenceHash) {
	    if (!($uriref =~ /^#/)) {
		if (!$HashCache{$uriref}) {
		    print STDERR "  fetching:     \t", $uriref, "\n";
		    $HashCache{$uriref} = sha1 (&get ($ua, $uriref));
		}

		if ($HashCache{$uriref} eq $ReferenceHash {$uriref}) {
#		    print "  expected hash: \t", &myBase64 ($ReferenceHash{$uriref}), "\n";
		    print STDERR "  pass:          \t", $uriref, "\n";
		} else {
		    print STDERR "  hash:            \t", &myBase64($HashCache{$uriref}), "\n";
		    print STDERR "  expected hash: \t", &myBase64 ($ReferenceHash{$uriref}), "\n";
		    print "Reference validation failed for ", $uriref, "\n";
		    die "BAD SIGNATURE";
		}
	    }
	}
	
	print STDERR ">>>>> CORE VALIDATION ENDS HERE", "\n";

	print STDERR "Checking against profile constraints", "\n";
	
	# main resource is checked for both profiles.
	if ($ReferenceHash{$the_uri}) {
	    print STDERR "  pass:                \t", $the_uri, "\n";
	} else {
	    print STDERR "  fail:               \t", $the_uri, "\n";
	    print "The main resource is not covered by the signature.", "\n";
	    die "BAD SIGNATURE";
	}

	if ($signatureURIs->{$u} eq "dsig-simple") {
	    print STDERR "SIMPLE profile: Only the main document is signed.", "\n";
	    print "GOOD SIGNATURE (simple profile): ", $u, "\n";
	} elsif ($signatureURIs->{$u} eq "dsig-full") {
	    print STDERR "FULL profile: Looking for main document and dependent content.", "\n";
	    for my $d (@dependent) {
		if ($ReferenceHash{$d}) {
		    print STDERR "  pass:          \t", $d, "\n";
		} elsif (!$ManifestHash{$d}) {
		    print STDERR "  fail:          \t", $d, "\n";
		    print "The dependent resource $d is not covered by the signature.", "\n";
		    die "BAD SIGNATURE";
		} else {
		    if (!$HashCache{$d}) {
			print STDERR "  fetching:      \t", $d, "\n";
			$HashCache{$d} = sha1 (&get ($ua, $d));
		    }
		    my $f = 0;
		    for my $h (@{$ManifestHash{$d}}) {
			$f = 1 if ($h eq $HashCache{$d});
		    }
		    
		    if ($f) {
			print STDERR "  pass (manifest): \t", $d, "\n";
		    } else {
			print STDERR "  fail (digest):   \t", $d, "\n";
			print "Reference validation failed for $d.", "\n";
			die "BAD SIGNATURE";
		    }
		}
	    }
	    print "GOOD SIGNATURE (full profile): ", $u, "\n";
	} else {
	    die "I'm confused.";
	}
    }
    
    die "Document wasn't signed at all. Sorry." if $notsignedatall;
}


sub constructReference ()
{
    my $dom = shift;
    my $hash = shift;
    my $pfx = (shift) . ':';
    my %params = @_;
    
    my $sha1 = 'http://www.w3.org/2000/09/xmldsig#sha1';
    
    my $ref = $dom->createElement ($pfx . 'Reference');
    
    $ref->setAttribute ('URI', $params{URI})   if defined ($params{URI});
    $ref->setAttribute ('Type', $params{Type}) if defined ($params{Type});
    
    if ($params{Transforms}) {
	my $dsTransforms = $ref->addChild ($dom->createElement ($pfx . 'Transforms'));
	for my $t (split (',', $params{Transforms})) {
	    my $oneTransform = $dom->createElement ($pfx . 'Transform');
	    $oneTransform->setAttribute ('Algorithm', $t);
	    $dsTransforms->addChild ($oneTransform);
	}
    }
    
    my $dsDigestMethod = $ref->addChild ($dom->createElement ($pfx . 'DigestMethod'));
    if ($params{DigestMethod}) {
	$dsDigestMethod->setAttribute ('Algorithm', $params{DigestMethod});
    } else {
	$dsDigestMethod->setAttribute ('Algorithm', $sha1);
    }
    
    my $dsDigestValue = $ref->addChild ($dom->createElement ($pfx . 'DigestValue'));
    $dsDigestValue->appendTextNode ($hash);
    
    return $ref;
}

sub stripws {
    my $r = '';

    for my $s (@_) {
	$s =~ s/[ \n\r]//g;
	$r .= $s;
    }
    
    return $r;
}

sub myBase64 {
    my $p = shift;
    return &stripws (encode_base64 ($p));
}

sub get {
    my $ua = shift;
    my $uri = shift;
    
    if ($#{$Rep{$uri}} > 0) {
	die "ERROR: $uri has multiple representations.\n";
    }
    if (${$Rep{$uri}}[0]) {
	$uri = ${$Rep{$uri}}[0];
	print STDERR "  representation:    \t", $uri, "\n";
    }
    
    my $response = $ua->get ($uri);
    if ($response->is_success) {
	return $response->content;
    } else {
	die "Can't get ${uri}: " .$response->status_line . "\n";
    }

}

sub strip_armor {
    my $s = shift;
    
    $s =~ s/-----(BEGIN|END)[A-Z ]*-----//g;
    return $s;
}

sub tolower {
    my $s = shift;
    $s =~ tr/A-Z/a-z/;
    return $s;
}

sub get_dependent_resources {
    my $base = shift;
    my $str = shift;
    
    my $state = {
	dependent => (),
	grddl => 0
    };

    my $htmlparser = HTML::Parser->new (api_version => 3);
    $htmlparser->handler (
	start => 
	sub {
	    my $tagname = &tolower (shift);
	    my $attr = shift;

	    $state->{grddl} = 1 if (($tagname eq 'head') and ($attr{profile} eq 'http://www.w3.org/2003/g/data-view'));
	    
	    if ($tagname eq 'link') {
		if ($attr->{rel} eq 'stylesheet') {
		    push @{$state->{dependent}}, URI->new_abs ($attr->{href}, $base);
		    print STDERR "  stylesheet         \t", $attr->{href}, "\n";
		} elsif (($attr->{rel} eq 'transform') and ($state->{grddl})) {
		    push @{$state->{dependent}}, URI->new_abs ($attr{href}, $base);
		    print STDERR "  GRDDL transform    \t", $attr->{href}, "\n";
		}
	    } elsif (($tagname eq 'img') or ($tagname eq 'input')) {
		if ($attr->{src}) {
		    push @{$state->{dependent}}, URI->new_abs ($attr->{src}, $base);
		    print STDERR "  image source      \t", $attr->{src}, "\n";
		} 
		if ($attr->{usemap}) {
		    push @{$state->{dependent}}, URI->new_abs ($attr->{usemap}, $base);
		    print STDERR "  image map         \t", $attr->{usemap}, "\n";
		}
	    } elsif ($tagname eq 'script') {
		if ($attr->{src}) {
		    push @{$state->{dependent}}, URI->new_abs ($attr->{src}, $base);
		    print STDERR "  script source      \t", $attr->{src}, "\n";
		}
	    } elsif ($tagname eq 'object') {
		my $codebase = $base;
		
		# Who had the brilliant idea to have two different kinds of base URI here?!
		
		if ($attr->{codebase}) {
		    $codebase = $attr->{codebase};
		}
		if ($attr->{classid}) {
		    push @{$state->{dependent}}, URI->new_abs ($attr->{classid}, $codebase);
		    print STDERR "  object classid     \t", $attr->{classid}, "\n";
		}
		if ($attr->{data}) {
		    push @{$state->{dependent}}, URI->new_abs ($attr->{dat}, $codebase);
		    print STDERR "  object data       \t", $attr->{data}, "\n";
		}
		if ($attr->{usemap}) {
		    push @{$state->{dependent}}, URI->new_abs ($attr->{data}, $base);
		    print STDERR "  object usemap     \t", $attr->{data}, "\n";
		}

	    }
	},
	
	"tagname, attr");
    
    $htmlparser->parse ($str);
    $htmlparser->eof;
    
    return @{$state->{dependent}};
}

sub get_signature_urls {
    my $base = shift;
    my $str = shift;
    
    my $state = {
	signatures => {},
	profile => 0
    };

    my $htmlparser = HTML::Parser->new (api_version => 3);
    $htmlparser->handler (
	start => 

	sub {
	    my $tagname = &tolower (shift);
	    my $attr = shift;

	    $state->{profile} = 1 if (($tagname eq 'head') and ($attr{profile} eq 'http://www.w3.org/2007/11/h6n/'));
	    
	    if ($tagname eq 'link') {
		if (($attr->{rel} eq 'dsig-full') or ($attr->{rel} eq 'dsig-simple')) {
		    my $u = URI->new_abs ($attr->{href}, $base);
		    $state->{signatures}->{$u->as_string} = $attr->{rel};
		    
		    print STDERR "  signature [", $attr->{rel}, "]\t", $u->as_string, "\n";
		    
		}
	    }
	},
	
	"tagname, attr");
    
    $htmlparser->parse ($str);
    $htmlparser->eof;

    return $state->{signatures};
}

sub generate_id {
    my $r = Crypt::OpenSSL::Random::random_bytes(10);
    return 'i' . sha1_hex ($r);
}

# Why is this necessary?
sub cleanup_cert {
    my $s = shift;
    my $d = '';
    
    $s =~ s/-----(BEGIN|END)[A-Z ]*-----//g;
    
    $s =~ s/[^A-Za-z0-9+\/=]//gm;

    $d = "-----BEGIN CERTIFICATE-----\n";
    
    $tail = $s;

    do {
	$head = substr $tail, 0, 64;
	if (length ($head) == 64) {
	    $tail = substr $tail, 64;
	} else {
	    $tail = '';
	}
	$d .= $head . "\n";
    } while ($tail);
    
    $d .= "-----END CERTIFICATE-----\n";
    return $d;
}