$suite security issues

#!/usr/bin/perl
# Must run on a machine with dak ls.
# 
# To check for un-updated binary kernel packages, also needs grep-dctrl 
# and a Sources file for the distribution. Set the location of the Sources
# file in SOURCES_FILE in the environment.
use warnings;
use strict;
use URI::Escape;
use Getopt::Long;

my $html=0;
my $debug=0;
my $suite="testing";
my $sta="http://security.debian.org/debian-security/dists/testing/updates/main/source/Sources.gz";
my $output;
if (! GetOptions(
		"html" => \$html,
		"debug" => \$debug,
		"suite=s" => \$suite,
		"sta=s" => \$sta,
		"output=s", \$output)
    || ! @ARGV) {
	die "usage: $0 [--suite suite] [--sta sta-mirror] [--html] [--output=file] [--debug] list ...\n";
}

my $stasources=`tempfile`;
chomp $stasources;
system("wget -q -O $stasources $sta");

if (defined $output) {
	open (OUT, ">$output.tmp.$$") || die "output.tmp.$$: $!"; # Set the output to a file
}
else {
	open (OUT, ">&STDOUT"); # Set the output to stdout
}

if ($html) { # It's HTML, so we need a header
	print OUT "<html><title>$suite security issues</title>\n";
	print OUT <<"EOF";
<p><b>Note:</b>The information in the <a href="http://idssi.enyo.de/tracker">Security
Bug Tracker</a> is more detailed and likely more accurate.
</p>
EOF

	
	# This is being run against something it's not meant to be, so print a warning
	if ($suite ne 'testing' && $suite ne 'unstable') { 
		print OUT <<"EOF";
<p>
<em>Warning:</em> This page is the result of running the testing security
check script against the $suite distribution. As data is only gathered for
the testing distribution, results may be innacurate if a package has
changed its name, if a vulnerability affects $suite and not testing, or if a
vulnerability has been fixed in $suite by the security team.
</p>
EOF
	}
	print OUT "<ul>\n";
}


my %data;
my %advlist;
my %needkernel=qw/2.4.27 0 2.6.11 0/;
my $list_unknown=1; #set to 1 to display kernel images with unknown source version
my $sources=$ENV{SOURCES_FILE};
my $need_rebuild=0;

# Set some colours for the urgency types
my @urgencies=("high", "medium", "low", "unimportant", "unknown", "fixed");
my %colormap=(
	high => "#FF0000",
	medium => "#FF9999",
	low => "#FFFFFF",
	unknown => "#FFFF00",
	fixed => "#00FF00",
);

my $unprop = my $unprop_all = my $unfixed = my $todos = my $fixedsta = 0;

# Add an item into the data array.
sub record {
	my ($package, $condition, $item, $urgency)=@_;

	if (! defined $item) {
		$item='';
	}
		
	if ($html) {
		$condition=~s{bug #(\d+)}{<a href="http://bugs.debian.org/$1">bug #$1</a>}g;
		$condition=~s{unfixed}{<b>unfixed</b>}g;
		$item=~s#(CVE-\d+-\d+)#<a href="http://cve.mitre.org/cgi-bin/cvename.cgi?name=$1">$1</a>#g;
		$item=~s#(DTSA-\d+-\d+)#<a href="http://testing-security.debian.net/DTSA/$1.html">$1</a>#g;
	}

	push @{$data{$package}{$condition}}, {item => $item, urgency => $urgency};
}

foreach my $list (@ARGV) {
	# Each of the @ARGVs we've got passed need parsing. So lets do that
	
	# If it's a directory, set the file to list, cause we need that.
	if (-d $list) {
		$list="$list/list";
	}
	
	my $id;
	open (IN, $list) || die "open $list: $!";
	while (<IN>) {
		print STDERR "line: $_" if $debug;
		chomp;
		if (/\s+TODO/) { # It's a todo item. Add it to the count, and ignore it
			$todos++;
		}
		elsif (/^\[/) { # Checking adv. number for a line starting with [ : Set $id to it
			($id)=m/((?:DSA|DTSA|CVE)-[^\s]+) /;
		}
		elsif (/^((?:DSA|DTSA|CVE)-[^\s]+)/) { # Check for a line with an advisory at the start : Set $id to it
			$id=$1;
		}
		elsif (/^\s+\[\w+\]\s+/) { # line tagged with a debian codename
			next; # don't handle these for now
		}
		elsif (/^\s+(?:\[\w+\]\s+)?[!-]\s+(\S+)\s+(.*?)\s*$/) { # Deal with the rest of the lines
			my $package=$1; # We know which package it is.
			my $rest=$2; 
			my $version;
			my $notes;
			if ($rest=~/([^\(\s]+)\s+\((.*)\)/) {
				$version=$1;
				$notes=$2;
			}
			elsif ($rest=~/\((.*)\)/) {
				$version="";
				$notes=$1;
			}
			else {
				$version=$rest;
				$notes="";
			}

			# by now, we also have the version that's affected by the security problem.
			# This is stored in $version
			next if $version eq '<not-affected>' || $version eq '<removed>' || $version eq '<no-dsa>';
			
			my @notes=split(/\s*;\s+/, $notes);

			# Fetch the urgency, if we can.
			my $urgency="unknown";
			foreach my $u (@urgencies) {
				if (grep { $_ eq $u } @notes) {
					$urgency=$u;
					@notes = grep { $_ ne $u } @notes;
					last;
				}
			}
			next if $urgency eq 'unimportant';
		
			# It's a kernel. Add it to the list of kernels that need to be looked at.
			if ($package=~/kernel-source-([0-9.]+)/ && $version ne '<unfixed>') {
			 	my $kernversion=$1;
				if (exists $needkernel{$kernversion} &&
				    length $version &&
				    system("dpkg --compare-versions $needkernel{$kernversion} lt $version") != 0) {
					$needkernel{$kernversion}=$version;
				}
			}

			# Fire up dak ls.
			my @maddy;
			for (1..5) {
				@maddy=`dak ls -s '$suite' '$package'`;
				if ($? & 127 || ($? >> 8 != 0 && $? >> 8 != 1)) {
					# good old unrelaible newraff,
					# home of our archive..
					next;
				}
				last;
			}
			if ($? & 127) {
				record($package, "<em>[dak ls segfaulted 5 times in a row.. Medic!]</em>", $id);
			}
			elsif ($? >> 8 != 0 && $? >> 8 != 1) {
				record($package, "<em>[dak ls exited with ".($? >> 8)."]</em>", $id);
			}
			if (! @maddy) {
				next;
			}
			
			if ($version eq '<unfixed>' || grep { $_ eq 'pending' } @notes) {
				record($package, '('.join("; ", "unfixed", @notes).')', $id, $urgency);
				$unfixed++;
				# It's not been fixed!
			}
			else {
				foreach my $maddy (@maddy) {
					my @fields = split(/\s*\|\s*/, $maddy);
					my $havver=$fields[1]; # It's this version in the archive I'm checking.
					my $arches=$fields[3];
					$version=~s/\s+//; # strip whitespace
					$arches=~s/\s+$//;
					next if $arches eq 'hurd-i386';
					# Is the version in the archive the same or newer than the fix?
					my $cmp=system("dpkg --compare-versions '$havver' '>=' '$version'"); 
					if ($cmp != 0){ # No, so the archive is vulnerable.
						# Does the version exist in the secure-testing archive?
						my $staversion = `zcat $stasources |grep-dctrl -F Package -e ^$package\$ -s Version -`;
						chomp $staversion;
						$staversion=~s/Version: //;
						$staversion=~s/\s+//;
						if (length ($staversion)) {
							# Yes, but what version is in s-t?
							my $stacmp = system("dpkg --compare-versions '$staversion' '>=' '$version'");
							if ($stacmp == 0){
								# Well, the version in the s-t archive fixes the issue
								# but it's still vulnerable in the main archive
								$urgency='fixed';
								$fixedsta++;
							}
						}
						
						if ($html && $suite eq 'testing') {
							$havver='<a href="http://release.debian.org/migration/testing.pl?package='.uri_escape($package).'">'.$havver.'</a>';
						}
						record($package, "$version needed, have $havver".(@maddy > 1 ? " [$arches]" : ""), $id, $urgency);
						$unprop++;
						$unprop_all++ unless @maddy > 1;
					}
				}
			}
		}
	}
}


foreach my $package (sort keys %data) {
	foreach my $condition (sort keys %{$data{$package}}) {
		print OUT "<li>" if $html;
		print OUT "$package $condition for ";
		my $items=0;
		foreach my $i (sort @{$data{$package}{$condition}}) {
			print OUT ", " if $items > 0;
			
			if ($html) {
				my $color=$colormap{$i->{urgency}};
				print OUT "<span style=\"background:$color\">";
			}
			print OUT $i->{item};
			if ($html) {
				print OUT "</span>";
			}
			
			$items++;
		}
		print OUT "\n";
	}
}

my %needkern;

foreach my $version (sort keys %needkernel) {
	my %images;
	
	if (defined $needkern{$version} && $needkern{$version} eq "0") {
		next;
	}

	my @dctrl;
	if (defined $sources && length $sources) {
		my $cat=($sources=~/\.gz/) ? "zcat" : "cat";
		@dctrl=`$cat $sources | grep-dctrl -F Binary kernel-image-$version -s Package,Build-Depends -`;
	}

	my $package="";
	my $haveversion;
	
	foreach my $line (@dctrl) {
		chomp $line;
		if ($line=~/Package:\s*(\S+)/) {
			$package=$1;
			$haveversion="0";
		} elsif ($line=~/Build-Depends/) {
			if ($line=~/kernel-tree-$version-([^,\s]+)/) {
				$haveversion="$version-$1";
			} elsif ($line=~/kernel-source-$version\s+\(>?=\s*([^\s\)]+)\)/) {
				$haveversion="$1";
			}
		} else {
			if ($package=~/linux-kernel-di/ || $package eq "") {
				next;
			}
			$images{$package}=$haveversion;
			$package="";
		}
	}

	foreach my $package (sort keys %images) {
		if ($images{$package} eq "0") {
			print OUT "<li>" if ($html && $list_unknown);
			print OUT "$package built from kernel-source-$version $needkernel{$version} needed, current version unknown\n" if $list_unknown;
		} elsif (!system("dpkg --compare-versions $needkernel{$version} gt $images{$package}")) {
			print OUT "<li>" if $html;
			print OUT "$package built from kernel-source-$version $needkernel{$version} needed, have $images{$package}\n";
			$need_rebuild++;
		}
	}


}


if ($html) {
	print OUT "</ul>\n";
	print OUT "<hr>\n";
	print OUT "Key: ";
	foreach my $keyline (@urgencies) {
		next if $keyline eq 'unimportant';
		print OUT "<span style=\"border: 1px dashed; background:".$colormap{$keyline}."\">&nbsp;$keyline&nbsp;</span> ";
	}
	print OUT "<br>";
	print OUT "Total holes unfixed: $unfixed<br>\n";
	print OUT "Total holes fixed in unstable (or experimental) but not $suite: $unprop_all ($fixedsta fixed in secure-testing archive)";
	if ($unprop_all != $unprop) {
		print OUT " (+".($unprop - $unprop_all)." on some arches)";
	}
	print OUT "<br>\n";
	print OUT "Total number of kernel image packages not up to date: $need_rebuild<br>\n";
	print OUT "Number of TODO lines in <a href=\"http://svn.debian.org/wsvn/secure-testing/data/?rev=0&sc=0\">records</a>: $todos<br>\n";
	print OUT "Maintained by the <a href=\"http://testing-security.debian.net/\">testing security team</a><br>\n";
	print OUT "Last update: ".`date`."<br>\n";
	print OUT "</html>\n";
}

close OUT;
if (defined $output) {
	rename("$output.tmp.$$", $output) || die "rename: $!";
}
unlink $stasources;